taffybar 1.0.2 → 2.0.0
raw patch · 117 files changed
+7175/−6769 lines, 117 filesdep +dbus-hsloggerdep +gi-cairodep +gi-glibdep ~gi-gdkpixbufdep ~haskell-gi-basedep ~process
Dependencies added: dbus-hslogger, gi-cairo, gi-glib, gtk-sni-tray, gtk-strut, haskell-gi, hslogger, optparse-applicative, regex-compat, status-notifier-item
Dependency ranges changed: gi-gdkpixbuf, haskell-gi-base, process, time
Files
- CHANGELOG.md +77/−0
- README.md +16/−13
- app/Main.hs +34/−3
- dbus-xml/org.mpris.MediaPlayer2.Player.xml +30/−0
- icons/play.svg +42/−0
- src/System/Information/Battery.hs +0/−189
- src/System/Information/CPU.hs +0/−35
- src/System/Information/CPU2.hs +0/−57
- src/System/Information/DiskIO.hs +0/−42
- src/System/Information/EWMHDesktopInfo.hs +0/−224
- src/System/Information/Memory.hs +0/−54
- src/System/Information/Network.hs +0/−61
- src/System/Information/SafeX11.hsc +0/−218
- src/System/Information/StreamInfo.hs +0/−90
- src/System/Information/Volume.hs +0/−38
- src/System/Information/X11DesktopInfo.hs +0/−282
- src/System/Taffybar.hs +101/−392
- src/System/Taffybar/Auth.hs +20/−0
- src/System/Taffybar/Battery.hs +0/−208
- src/System/Taffybar/CPUMonitor.hs +0/−40
- src/System/Taffybar/CommandRunner.hs +0/−48
- src/System/Taffybar/Compat/GtkLibs.hs +55/−0
- src/System/Taffybar/Context.hs +218/−12
- src/System/Taffybar/DBus.hs +27/−0
- src/System/Taffybar/DBus/Toggle.hs +167/−0
- src/System/Taffybar/DiskIOMonitor.hs +0/−37
- src/System/Taffybar/FSMonitor.hs +0/−38
- src/System/Taffybar/FreedesktopNotifications.hs +0/−280
- src/System/Taffybar/GtkLibCompat.hs +0/−45
- src/System/Taffybar/Hooks.hs +21/−0
- src/System/Taffybar/Hooks/PagerHints.hs +0/−115
- src/System/Taffybar/IconImages.hs +3/−14
- src/System/Taffybar/Information/Battery.hs +198/−0
- src/System/Taffybar/Information/CPU.hs +35/−0
- src/System/Taffybar/Information/CPU2.hs +64/−0
- src/System/Taffybar/Information/DBusClients.hs +11/−0
- src/System/Taffybar/Information/DBusObjects.hs +34/−0
- src/System/Taffybar/Information/DiskIO.hs +42/−0
- src/System/Taffybar/Information/EWMHDesktopInfo.hs +224/−0
- src/System/Taffybar/Information/MPRIS2.hs +70/−0
- src/System/Taffybar/Information/Memory.hs +55/−0
- src/System/Taffybar/Information/Network.hs +141/−0
- src/System/Taffybar/Information/SafeX11.hsc +218/−0
- src/System/Taffybar/Information/StreamInfo.hs +89/−0
- src/System/Taffybar/Information/Volume.hs +40/−0
- src/System/Taffybar/Information/X11DesktopInfo.hs +285/−0
- src/System/Taffybar/Information/XDG/DesktopEntry.hs +215/−0
- src/System/Taffybar/Information/XDG/Protocol.hs +259/−0
- src/System/Taffybar/LayoutSwitcher.hs +0/−113
- src/System/Taffybar/MPRIS.hs +0/−109
- src/System/Taffybar/MPRIS2.hs +0/−127
- src/System/Taffybar/Menu/DesktopEntry.hs +0/−179
- src/System/Taffybar/Menu/Menu.hs +0/−124
- src/System/Taffybar/Menu/MenuWidget.hs +0/−129
- src/System/Taffybar/Menu/XdgMenu.hs +0/−277
- src/System/Taffybar/NetMonitor.hs +0/−138
- src/System/Taffybar/Pager.hs +0/−200
- src/System/Taffybar/PixbufCompat.hs +0/−71
- src/System/Taffybar/SimpleClock.hs +0/−119
- src/System/Taffybar/SimpleConfig.hs +149/−0
- src/System/Taffybar/StrutProperties.hs +0/−35
- src/System/Taffybar/Support/PagerHints.hs +115/−0
- src/System/Taffybar/Systray.hs +0/−21
- src/System/Taffybar/TaffyPager.hs +0/−121
- src/System/Taffybar/Text/CPUMonitor.hs +0/−29
- src/System/Taffybar/Text/MemoryMonitor.hs +0/−29
- src/System/Taffybar/ToggleMonitor.hs +0/−125
- src/System/Taffybar/TransparentWindow.hs +59/−0
- src/System/Taffybar/Util.hs +55/−0
- src/System/Taffybar/Volume.hs +0/−28
- src/System/Taffybar/Weather.hs +0/−318
- src/System/Taffybar/Widget.hs +110/−0
- src/System/Taffybar/Widget/Battery.hs +215/−0
- src/System/Taffybar/Widget/CPUMonitor.hs +43/−0
- src/System/Taffybar/Widget/CommandRunner.hs +43/−0
- src/System/Taffybar/Widget/Decorators.hs +20/−0
- src/System/Taffybar/Widget/DiskIOMonitor.hs +40/−0
- src/System/Taffybar/Widget/FSMonitor.hs +41/−0
- src/System/Taffybar/Widget/FreedesktopNotifications.hs +275/−0
- src/System/Taffybar/Widget/Generic/ChannelGraph.hs +20/−0
- src/System/Taffybar/Widget/Generic/DynamicMenu.hs +32/−0
- src/System/Taffybar/Widget/Generic/Graph.hs +241/−0
- src/System/Taffybar/Widget/Generic/Icon.hs +57/−0
- src/System/Taffybar/Widget/Generic/PollingBar.hs +32/−0
- src/System/Taffybar/Widget/Generic/PollingGraph.hs +36/−0
- src/System/Taffybar/Widget/Generic/PollingLabel.hs +59/−0
- src/System/Taffybar/Widget/Generic/VerticalBar.hs +178/−0
- src/System/Taffybar/Widget/Layout.hs +107/−0
- src/System/Taffybar/Widget/MPRIS2.hs +133/−0
- src/System/Taffybar/Widget/NetMonitor.hs +104/−0
- src/System/Taffybar/Widget/NetworkGraph.hs +23/−0
- src/System/Taffybar/Widget/SNITray.hs +52/−0
- src/System/Taffybar/Widget/SimpleClock.hs +119/−0
- src/System/Taffybar/Widget/Systray.hs +22/−0
- src/System/Taffybar/Widget/Text/CPUMonitor.hs +29/−0
- src/System/Taffybar/Widget/Text/MemoryMonitor.hs +29/−0
- src/System/Taffybar/Widget/Text/NetworkMonitor.hs +70/−0
- src/System/Taffybar/Widget/Util.hs +155/−0
- src/System/Taffybar/Widget/Volume.hs +26/−0
- src/System/Taffybar/Widget/Weather.hs +323/−0
- src/System/Taffybar/Widget/Windows.hs +104/−0
- src/System/Taffybar/Widget/Workspaces.hs +879/−0
- src/System/Taffybar/Widget/XDGMenu/Menu.hs +136/−0
- src/System/Taffybar/Widget/XDGMenu/MenuWidget.hs +132/−0
- src/System/Taffybar/Widgets/Graph.hs +0/−242
- src/System/Taffybar/Widgets/Icon.hs +0/−58
- src/System/Taffybar/Widgets/PollingBar.hs +0/−33
- src/System/Taffybar/Widgets/PollingGraph.hs +0/−37
- src/System/Taffybar/Widgets/PollingLabel.hs +0/−64
- src/System/Taffybar/Widgets/Util.hs +0/−74
- src/System/Taffybar/Widgets/VerticalBar.hs +0/−179
- src/System/Taffybar/WindowSwitcher.hs +0/−141
- src/System/Taffybar/WorkspaceHUD.hs +0/−992
- src/gdk_property_change_wrapper.c +0/−29
- taffybar.cabal +91/−67
- taffybar.css +5/−1
- taffybar.hs.example +25/−25
CHANGELOG.md view
@@ -1,9 +1,86 @@+# 2.0.0++## Breaking Changes++ * An entirely new config system has been put in place. TaffybarConfig now lives+ in System.Taffybar.Context, but for most users, System.Taffybar.SimpleConfig+ is the configuration interface that should be used.++ * The main entry point to taffybar is now dyreTaffybar instead of+ defaultTaffybar.++ * All widget constructors provided to both config systems must now be of type+ `TaffyIO Gtk.Widget`. If you have an existing `IO Gtk.Widget` you can convert it+ using liftIO. All widgets provided by taffybar are now of type+ `MonadIO m => m Gtk.Widget`, or specialized to `TaffyIO Gtk.Widgets`.++ * The `graphBackgroundColor` and `graphBorderColor` fields are now RGBA+ quadruples instead of RGB triples.++ * Module removals:++ - WorkspaceSwitcher: Workspaces is much more abstract and makes this widget+ redundant.+ - Pager: The Context module solves the problem that Pager solved in a much+ more general way. It also makes it so that the user doesn't even need to+ know about the Pager component at all.+ - TaffyPager: Since you no longer need to explicitly initialize a Pager, it's+ not really very hard to simply add the (Workspaces, Layout, Windows) triple+ to your config any more.+ - XMonadLog: This module has long been deprecated++ * Module moves:++ - Everything in System.Information has been moved to+ System.Information.Taffybar+ - All Widgets that were found in System.Taffybar have been moved to+ System.Taffybar.Widget+ - The helper widgets that were previously located in System.Taffybar.Widgets+ have been moved to System.Taffybar.Widget.Generic++ * Module renames:++ - WorkspaceHUD -> Workspaces+ - WindowSwitcher -> Windows+ - LayoutSwitcher -> Layout+ - ToggleMonitors -> DBus.Toggle++ * Module deprecations:++ - System.Taffybar.Widget.Systray (Use SNITray instead)+ - System.Taffybar.Widget.NetMonitor (Use+ System.Taffybar.Widget.Text.NetworkMonitor instead)++ * Many widgets have subtle interface changes that may break existing configurations.++## New Features++ * Widgets can now be placed in the center of taffybar with the `centerWidgets`+ configuration parameter.++ * taffybar is now transparent by default, but you will need to use a compositor+ for transparency to work. https://github.com/chjj/compton is recommended. If+ you do not want a transparent taffybar set a background color on the class+ `TaffyBox` in taffybar.css.++ * StatusNotifierItem support has been added to taffybar in the SNITray module.++ * Monitor configuration changes are handled automatically. Unfortunately the+ bar must be completely recreated when this happens.++ * New network monitor widgets `System.Taffybar.Widget.Text.NetworkMonitor`+ and `System.Taffybar.Widget.NetworkGraph` were added.++ * All widgets are now exported in `System.Taffybar.Widget`, which should+ eliminate the need to import widgets explicitly.+ # 1.0.2 ## Bug Fixes * Fix long standing memory leak that was caused by a failure to free memory allocated for gtk pixbufs.+ * Widgets unregister from X11 event listening. # 1.0.0
README.md view
@@ -1,11 +1,11 @@ Taffybar-==========+======== [](https://hackage.haskell.org/package/taffybar)-[](https://travis-ci.org/travitch/taffybar)+[](https://travis-ci.org/taffybar/taffybar) [](https://gitter.im/taffybar/Lobby)-[](https://github.com/travitch/taffybar/blob/master/LICENSE)+[](https://github.com/taffybar/taffybar/blob/master/LICENSE) -+ 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@@ -18,18 +18,18 @@ 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.+project](https://github.com/taffybar/taffybar/projects/1). Installation ------------ -Taffybar can be installed in a number of different ways:+Taffybar has a number of non-haskell dependencies. It is recommended that you+follow the installation instructions for+[haskell-gi](https://github.com/haskell-gi/haskell-gi) before attempting to+install taffybar. +Taffybar itself can be installed in a number of different ways:+ ### Stack Though it is admittedly a bit complicated to set up properly, using stack is the@@ -39,7 +39,7 @@ quick-start script: ```-curl -sSL https://raw.githubusercontent.com/travitch/taffybar/master/quick-start.sh | bash+curl -sSL https://raw.githubusercontent.com/taffybar/taffybar/master/quick-start.sh | bash ``` This script will clone the taffybar repository into a subdirectory of the@@ -66,4 +66,7 @@ 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).+For more details about how to configure taffybar, see the [full+documentation](https://hackage.haskell.org/package/taffybar). You can find a+list of available widgets+[here](http://hackage.haskell.org/package/taffybar-1.0.2/docs/System-Taffybar-Widget.html)
app/Main.hs view
@@ -1,9 +1,40 @@--- | This is just a stub executable that uses dyre to read the config--- file and recompile itself.+-- | This is just a stub executable that uses dyre to read the config file and+-- recompile itself. module Main ( main ) where +import Data.Semigroup ((<>))+import Data.Version+import Options.Applicative+import System.Log.Logger import System.Taffybar+import System.Taffybar.Context+import Text.Printf +import Paths_taffybar (version)++logP :: Parser Priority+logP =+ option auto+ ( long "log-level"+ <> short 'l'+ <> help "Set the log level"+ <> metavar "LEVEL"+ <> value WARNING+ )++versionOption :: Parser (a -> a)+versionOption = infoOption+ (printf "taffybar %s" $ showVersion version)+ ( long "version"+ <> help "Show the version number of gtk-sni-tray"+ )+ main :: IO () main = do- defaultTaffybar defaultTaffybarConfig+ logLevel <- execParser $ info (helper <*> versionOption <*> logP)+ ( fullDesc+ <> progDesc "Start taffybar, recompiling if necessary"+ )+ logger <- getLogger "System.Taffybar"+ saveGlobalLogger $ setLevel logLevel logger+ dyreTaffybar defaultTaffybarConfig
+ dbus-xml/org.mpris.MediaPlayer2.Player.xml view
@@ -0,0 +1,30 @@+<node>+ <interface name="org.mpris.MediaPlayer2.Player">+ <property name="CanControl" type="b" access="read"/>+ <property name="CanGoNext" type="b" access="read"/>+ <property name="CanGoPrevious" type="b" access="read"/>+ <property name="CanPause" type="b" access="read"/>+ <property name="CanPlay" type="b" access="read"/>+ <property name="CanSeek" type="b" access="read"/>+ <property name="Metadata" type="a{sv}" access="read"/>+ <property name="PlaybackStatus" type="s" access="read"/>+ <property name="Position" type="x" access="read"/>+ <property name="Volume" type="d" access="read"/>+ <method name="Next"/>+ <method name="Pause"/>+ <method name="Play"/>+ <method name="PlayPause"/>+ <method name="Previous"/>+ <method name="Seek">+ <arg name="offset" type="x" direction="in"/>+ </method>+ <method name="SetPosition">+ <arg name="trackId" type="o" direction="in"/>+ <arg name="position" type="x" direction="in"/>+ </method>+ <method name="Stop"/>+ <signal name="Seeked">+ <arg name="position" type="x" direction="out"/>+ </signal>+ </interface>+</node>
+ icons/play.svg view
@@ -0,0 +1,42 @@+<?xml version="1.0" encoding="iso-8859-1"?> +<!-- Generator: Adobe Illustrator 19.0.0, SVG Export Plug-In . SVG Version: 6.00 Build 0) --> +<svg version="1.1" id="Capa_1" xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink" x="0px" y="0px" + viewBox="0 0 58 58" style="enable-background:new 0 0 58 58;" xml:space="preserve"> +<circle style="fill:#EBBA16;" cx="29" cy="29" r="29"/> +<g> + <polygon style="fill:#FFFFFF;" points="44,29 22,44 22,29.273 22,14 "/> + <path style="fill:#FFFFFF;" d="M22,45c-0.16,0-0.321-0.038-0.467-0.116C21.205,44.711,21,44.371,21,44V14 + c0-0.371,0.205-0.711,0.533-0.884c0.328-0.174,0.724-0.15,1.031,0.058l22,15C44.836,28.36,45,28.669,45,29s-0.164,0.64-0.437,0.826 + l-22,15C22.394,44.941,22.197,45,22,45z M23,15.893v26.215L42.225,29L23,15.893z"/> +</g> +<g> +</g> +<g> +</g> +<g> +</g> +<g> +</g> +<g> +</g> +<g> +</g> +<g> +</g> +<g> +</g> +<g> +</g> +<g> +</g> +<g> +</g> +<g> +</g> +<g> +</g> +<g> +</g> +<g> +</g> +</svg>
− src/System/Information/Battery.hs
@@ -1,189 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--- | This is a simple library to query the Linux UPower daemon (via--- DBus) for battery information. Currently, it only retrieves--- information for the first battery it finds.-module System.Information.Battery (- -- * Types- BatteryContext,- BatteryInfo(..),- BatteryState(..),- BatteryTechnology(..),- BatteryType(..),- -- * Accessors- batteryContextsNew,- getBatteryInfo- ) where--import Data.Map ( Map )-import qualified Data.Map as M-import Data.Maybe ( fromMaybe, maybeToList )-import Data.Word-import Data.Int-import DBus-import DBus.Client-import Data.List ( isInfixOf )-import Data.Text ( Text )-import qualified Data.Text as T-import Safe ( atMay )---- | An opaque wrapper around some internal library state-data BatteryContext = BC Client ObjectPath--data BatteryType = BatteryTypeUnknown- | BatteryTypeLinePower- | BatteryTypeBatteryType- | BatteryTypeUps- | BatteryTypeMonitor- | BatteryTypeMouse- | BatteryTypeKeyboard- | BatteryTypePda- | BatteryTypePhone- deriving (Show, Ord, Eq, Enum)--data BatteryState = BatteryStateUnknown- | BatteryStateCharging- | BatteryStateDischarging- | BatteryStateEmpty- | BatteryStateFullyCharged- | BatteryStatePendingCharge- | BatteryStatePendingDischarge- deriving (Show, Ord, Eq, Enum)--data BatteryTechnology = BatteryTechnologyUnknown- | BatteryTechnologyLithiumIon- | BatteryTechnologyLithiumPolymer- | BatteryTechnologyLithiumIronPhosphate- | BatteryTechnologyLeadAcid- | BatteryTechnologyNickelCadmium- | BatteryTechnologyNickelMetalHydride- deriving (Show, Ord, Eq, Enum)---- | There are a few fields supported by UPower that aren't exposed--- here.. could be easily.-data BatteryInfo = BatteryInfo { batteryNativePath :: Text- , batteryVendor :: Text- , batteryModel :: Text- , batterySerial :: Text- -- , batteryUpdateTime :: Time- , batteryType :: BatteryType- , batteryPowerSupply :: Bool- , batteryHasHistory :: Bool- , batteryHasStatistics :: Bool- , batteryOnline :: Bool- , batteryEnergy :: Double- , batteryEnergyEmpty :: Double- , batteryEnergyFull :: Double- , batteryEnergyFullDesign :: Double- , batteryEnergyRate :: Double- , batteryVoltage :: Double- , batteryTimeToEmpty :: Int64- , batteryTimeToFull :: Int64- , batteryPercentage :: Double- , batteryIsPresent :: Bool- , batteryState :: BatteryState- , batteryIsRechargable :: Bool- , batteryCapacity :: Double- , batteryTechnology :: BatteryTechnology-{- , batteryRecallNotice :: Bool- , batteryRecallVendor :: Text- , batteryRecallUr :: Text--}- }---- | determine if a power source is a battery. The simple heuristic is a--- substring search on 'BAT'.-isBattery :: ObjectPath -> Bool-isBattery = isInfixOf "BAT" . formatObjectPath---- | Find the power sources that are batteries (according to--- 'isBattery')-batteries :: [ObjectPath] -> [ObjectPath]-batteries = filter isBattery---- | The name of the power daemon bus-powerBusName :: BusName-powerBusName = "org.freedesktop.UPower"---- | The base object path-powerBaseObjectPath :: ObjectPath-powerBaseObjectPath = "/org/freedesktop/UPower"---- | A helper to read the variant contents of a dict with a default--- value.-readDict :: (IsVariant a) => Map Text Variant -> Text -> a -> a-readDict dict key dflt = fromMaybe dflt $ do- variant <- M.lookup key dict- fromVariant variant---- | Read the variant contents of a dict which is of an unknown integral type.-readDictIntegral :: Map Text Variant -> Text -> Int32 -> Int-readDictIntegral dict key dflt = fromMaybe (fromIntegral dflt) $ do- v <- M.lookup key dict- case variantType v of- TypeWord8 -> return $ fromIntegral (f v :: Word8)- TypeWord16 -> return $ fromIntegral (f v :: Word16)- TypeWord32 -> return $ fromIntegral (f v :: Word32)- TypeWord64 -> return $ fromIntegral (f v :: Word64)- TypeInt16 -> return $ fromIntegral (f v :: Int16)- TypeInt32 -> return $ fromIntegral (f v :: Int32)- TypeInt64 -> return $ fromIntegral (f v :: Int64)- _ -> Nothing- where- f :: (Num a, IsVariant a) => Variant -> a- f = fromMaybe (fromIntegral dflt) . fromVariant---- | Query the UPower daemon about information on a specific battery.--- If some fields are not actually present, they may have bogus values--- here. Don't bet anything critical on it.-getBatteryInfo :: BatteryContext -> IO (Maybe BatteryInfo)-getBatteryInfo (BC systemConn battPath) = do- -- Grab all of the properties of the battery each call with one- -- message.- reply <- call_ systemConn (methodCall battPath "org.freedesktop.DBus.Properties" "GetAll")- { methodCallDestination = Just "org.freedesktop.UPower"- , methodCallBody = [toVariant $ T.pack "org.freedesktop.UPower.Device"]- }-- return $ do- body <- methodReturnBody reply `atMay` 0- dict <- fromVariant body- return BatteryInfo { batteryNativePath = readDict dict "NativePath" ""- , batteryVendor = readDict dict "Vendor" ""- , batteryModel = readDict dict "Model" ""- , batterySerial = readDict dict "Serial" ""- , batteryType = toEnum $ fromIntegral $ readDictIntegral dict "Type" 0- , batteryPowerSupply = readDict dict "PowerSupply" False- , batteryHasHistory = readDict dict "HasHistory" False- , batteryHasStatistics = readDict dict "HasStatistics" False- , batteryOnline = readDict dict "Online" False- , batteryEnergy = readDict dict "Energy" 0.0- , batteryEnergyEmpty = readDict dict "EnergyEmpty" 0.0- , batteryEnergyFull = readDict dict "EnergyFull" 0.0- , batteryEnergyFullDesign = readDict dict "EnergyFullDesign" 0.0- , batteryEnergyRate = readDict dict "EnergyRate" 0.0- , batteryVoltage = readDict dict "Voltage" 0.0- , batteryTimeToEmpty = readDict dict "TimeToEmpty" 0- , batteryTimeToFull = readDict dict "TimeToFull" 0- , batteryPercentage = readDict dict "Percentage" 0.0- , batteryIsPresent = readDict dict "IsPresent" False- , batteryState = toEnum $ readDictIntegral dict "State" 0- , batteryIsRechargable = readDict dict "IsRechargable" True- , batteryCapacity = readDict dict "Capacity" 0.0- , batteryTechnology =- toEnum $ fromIntegral $ readDictIntegral dict "Technology" 0- }----- | Construct a battery context for every battery in the system. This--- could fail if the UPower daemon is not running. The contexts can be--- used to get actual battery state with 'getBatteryInfo'.-batteryContextsNew :: IO [BatteryContext]-batteryContextsNew = do- systemConn <- connectSystem- let mc = methodCall powerBaseObjectPath "org.freedesktop.UPower" "EnumerateDevices"- reply <- call_ systemConn mc { methodCallDestination = Just powerBusName }- return $ do- body <- take 1 $ methodReturnBody reply- powerDevices <- maybeToList $ fromVariant body- battPath <- batteries powerDevices- return $ BC systemConn battPath
− src/System/Information/CPU.hs
@@ -1,35 +0,0 @@-module System.Information.CPU ( cpuLoad ) where--import Control.Concurrent ( threadDelay )-import System.IO ( IOMode(ReadMode), openFile, hGetLine, hClose )--procData :: IO [Double]-procData = do- h <- openFile "/proc/stat" ReadMode- firstLine <- hGetLine h- (length firstLine) `seq` return ()- hClose h- return (procParser firstLine)--procParser :: String -> [Double]-procParser = map read . tail . words--truncVal :: Double -> Double-truncVal v- | isNaN v || v < 0.0 = 0.0- | otherwise = v---- | Return a pair with (user time, system time, total time) (read--- from /proc/stat). The function waits for 50 ms between samples.-cpuLoad :: IO (Double, Double, Double)-cpuLoad = do- a <- procData- threadDelay 50000- b <- procData- let dif = zipWith (-) b a- tot = foldr (+) 0 dif- pct = map (/ tot) dif- user = foldr (+) 0 $ take 2 pct- system = pct !! 2- t = user + system- return (truncVal user, truncVal system, truncVal t)
− src/System/Information/CPU2.hs
@@ -1,57 +0,0 @@--------------------------------------------------------------------------------- |--- Module : System.Information.CPU2--- Copyright : (c) José A. Romero L.--- License : BSD3-style (see LICENSE)------ Maintainer : José A. Romero L. <escherdragon@gmail.com>--- Stability : unstable--- Portability : unportable------ Provides information about used CPU times, obtained from parsing the--- @\/proc\/stat@ file using some of the facilities included in the--- "System.Information.StreamInfo" module.--- And also provides information about the temperature of cores.--- (Now supports only physical cpu).-----------------------------------------------------------------------------------module System.Information.CPU2 ( getCPULoad, getCPUInfo, getCPUTemp ) where--import Data.Maybe ( mapMaybe )-import Safe ( atMay, readDef, tailSafe )-import System.Information.StreamInfo ( getLoad, getParsedInfo )-import Control.Monad (liftM)---- | Returns a two-element list containing relative system and user times--- calculated using two almost simultaneous samples of the @\/proc\/stat@ file--- for the given core (or all of them aggregated, if \"cpu\" is passed).-getCPULoad :: String -> IO [Double]-getCPULoad cpu = do- load <- getLoad 0.05 $ getCPUInfo cpu- case load of- l0:l1:l2:_ -> return [ l0 + l1, l2 ]- _ -> return []---- | Returns a list containing temperatures of user given cpu cores.--- Use ["cpu1", "cpu2".."cpuN"] to get temperature of exact cores.--- Use ["cpu0"] to get common temperature.-getCPUTemp :: [String] -> IO [Int]-getCPUTemp cpus = do- let cpus' = map (\s -> [last s]) cpus- liftM concat $ mapM (\cpu -> getParsedInfo ("/sys/bus/platform/devices/coretemp.0/temp" ++ show ((read cpu::Int) + 1) ++ "_input") (\s -> [("temp", [(read s::Int) `div` 1000])]) "temp") cpus'- --TODO and suppoprt for more than 1 physical cpu.---- | Returns a list of 5 to 7 elements containing all the values available for--- the given core (or all of them aggregated, if "cpu" is passed).-getCPUInfo :: String -> IO [Int]-getCPUInfo = getParsedInfo "/proc/stat" parse--parse :: String -> [(String, [Int])]-parse = mapMaybe (tuplize . words) . filter (\x -> take 3 x == "cpu") . lines--tuplize :: [String] -> Maybe (String, [Int])-tuplize s = do- cpu <- s `atMay` 0- return (cpu, map (readDef (-1)) (tailSafe s))-
− src/System/Information/DiskIO.hs
@@ -1,42 +0,0 @@--------------------------------------------------------------------------------- |--- Module : System.Information.DiskIO--- Copyright : (c) José A. Romero L.--- License : BSD3-style (see LICENSE)------ Maintainer : José A. Romero L. <escherdragon@gmail.com>--- Stability : unstable--- Portability : unportable------ Provides information about read/write operations in a given disk or--- partition, obtained from parsing the @\/proc\/diskstats@ file with some--- of the facilities included in the "System.Information.StreamInfo" module.--------------------------------------------------------------------------------module System.Information.DiskIO ( getDiskTransfer ) where--import Data.Maybe ( mapMaybe )-import Safe ( atMay, headMay, readDef )-import System.Information.StreamInfo ( getParsedInfo, getTransfer )---- | Returns a two-element list containing the speed of transfer for read and--- write operations performed in the given disk\/partition (e.g. \"sda\",--- \"sda1\").-getDiskTransfer :: String -> IO [Double]-getDiskTransfer disk = getTransfer 0.05 $ getDiskInfo disk---- | Returns the list of all the values available in @\/proc\/diskstats@--- for the given disk or partition.-getDiskInfo :: String -> IO [Int]-getDiskInfo = getParsedInfo "/proc/diskstats" parse--parse :: String -> [(String, [Int])]-parse = mapMaybe tuplize . map (drop 2 . words) . lines--tuplize :: [String] -> Maybe (String, [Int])-tuplize s = do- device <- headMay s- used <- s `atMay` 3- capacity <- s `atMay` 7- return (device, [readDef (-1) used, readDef (-1) capacity])-
− src/System/Information/EWMHDesktopInfo.hs
@@ -1,224 +0,0 @@--------------------------------------------------------------------------------- |--- Module : System.Information.EWMHDesktopInfo--- Copyright : (c) José A. Romero L.--- License : BSD3-style (see LICENSE)------ Maintainer : José A. Romero L. <escherdragon@gmail.com>--- Stability : unstable--- Portability : unportable------ Functions to access data provided by the X11 desktop via EWHM hints. This--- module requires that the EwmhDesktops hook from the XMonadContrib project--- be installed in your @~\/.xmonad\/xmonad.hs@ configuration:------ > import XMonad--- > import XMonad.Hooks.EwmhDesktops (ewmh)--- >--- > main = xmonad $ ewmh $ ...-----------------------------------------------------------------------------------module System.Information.EWMHDesktopInfo- ( X11Window -- re-exported from X11DesktopInfo- , X11WindowHandle- , WorkspaceIdx(..)- , EWMHIcon(..)- , EWMHIconData- , withDefaultCtx -- re-exported from X11DesktopInfo- , isWindowUrgent -- re-exported from X11DesktopInfo- , getCurrentWorkspace- , getVisibleWorkspaces- , getWorkspaceNames- , switchToWorkspace- , switchOneWorkspace- , withEWMHIcons- , getWindowTitle- , getWindowClass- , getWindowIconsData- , getActiveWindowTitle- , getWindows- , getWindowHandles- , getWorkspace- , focusWindow- ) where--import Control.Applicative-import Control.Monad.Trans-import Data.Maybe-import Data.Tuple-import Data.Word-import Debug.Trace-import Foreign.ForeignPtr-import Foreign.Marshal.Array-import Foreign.Ptr-import Foreign.Storable-import System.Information.SafeX11--import Prelude--import System.Information.X11DesktopInfo---- | Convenience alias for a pair of the form (props, window), where props is a--- tuple of the form (workspace index, window title, window class), and window--- is the internal ID of an open window.-type X11WindowHandle = ((WorkspaceIdx, String, String), X11Window)--newtype WorkspaceIdx = WSIdx Int- deriving (Show, Read, Ord, Eq)---- A super annoying detail of the XGetWindowProperty interface is that: "If the--- returned format is 32, the returned data is represented as a long array and--- should be cast to that type to obtain the elements." This means that even--- though only the 4 least significant bits will ever contain any data, the--- array that is returned from X11 can have a larger word size. This means that--- we need to manipulate the underlying data in annoying ways to pass it to gtk--- appropriately.-type PixelsWordType = Word64--type EWMHIconData = (ForeignPtr PixelsWordType, Int)--data EWMHIcon = EWMHIcon- { width :: Int- , height :: Int- , pixelsARGB :: Ptr PixelsWordType- } deriving (Show, Eq)--noFocus :: String-noFocus = "..."---- | Retrieve the index of the current workspace in the desktop,--- starting from 0.-getCurrentWorkspace :: X11Property WorkspaceIdx-getCurrentWorkspace = WSIdx <$> readAsInt Nothing "_NET_CURRENT_DESKTOP"---- | Retrieve the indexes of all currently visible workspaces--- with the active workspace at the head of the list.-getVisibleWorkspaces :: X11Property [WorkspaceIdx]-getVisibleWorkspaces = do- vis <- getVisibleTags- allNames <- map swap <$> getWorkspaceNames- cur <- getCurrentWorkspace- return $ cur : mapMaybe (`lookup` allNames) vis---- | Return a list with the names of all the workspaces currently--- available.-getWorkspaceNames :: X11Property [(WorkspaceIdx, String)]-getWorkspaceNames = go <$> readAsListOfString Nothing "_NET_DESKTOP_NAMES"- where go = zip [WSIdx i | i <- [0..]]---- | Ask the window manager to switch to the workspace with the given--- index, starting from 0.-switchToWorkspace :: WorkspaceIdx -> X11Property ()-switchToWorkspace (WSIdx idx) = do- cmd <- getAtom "_NET_CURRENT_DESKTOP"- sendCommandEvent cmd (fromIntegral idx)---- | Move one workspace up or down from the current workspace-switchOneWorkspace :: Bool -> Int -> X11Property ()-switchOneWorkspace dir end = do- cur <- getCurrentWorkspace- switchToWorkspace $ if dir then getPrev cur end else getNext cur end---- | Check for corner case and switch one workspace up-getPrev :: WorkspaceIdx -> Int -> WorkspaceIdx-getPrev (WSIdx idx) end- | idx > 0 = WSIdx $ idx-1- | otherwise = WSIdx end---- | Check for corner case and switch one workspace down-getNext :: WorkspaceIdx -> Int -> WorkspaceIdx-getNext (WSIdx idx) end- | idx < end = WSIdx $ idx+1- | otherwise = WSIdx 0---- | Get the title of the given X11 window.-getWindowTitle :: X11Window -> X11Property String-getWindowTitle window = do- let w = Just window- prop <- readAsString w "_NET_WM_NAME"- case prop of- "" -> readAsString w "WM_NAME"- _ -> return prop---- | Get the class of the given X11 window.-getWindowClass :: X11Window -> X11Property String-getWindowClass window = readAsString (Just window) "WM_CLASS"---- | Get EWMHIconData for the given X11Window-getWindowIconsData :: X11Window -> X11Property (Maybe EWMHIconData)-getWindowIconsData window = do- dpy <- getDisplay- atom <- getAtom "_NET_WM_ICON"- 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- iwidth <- fromIntegral <$> peek arr- iheight <- fromIntegral <$> peekElemOff arr 1- let pixelsPtr = advancePtr arr 2- thisSize = iwidth * iheight- newArr = advancePtr pixelsPtr thisSize- thisIcon =- EWMHIcon- { width = iwidth- , height = iheight- , pixelsARGB = pixelsPtr- }- getRes newSize- | newSize < 0 = trace "This should not happen parseIcons" return []- | otherwise = (thisIcon :) <$> parseIcons newSize newArr -- Keep going- getRes $ totalSize - fromIntegral (thisSize + 2)--withActiveWindow :: (X11Window -> X11Property String) -> X11Property String-withActiveWindow getProp = do- awt <- readAsListOfWindow Nothing "_NET_ACTIVE_WINDOW"- let w = listToMaybe $ filter (>0) awt- maybe (return noFocus) getProp w---- | Get the title of the currently focused window.-getActiveWindowTitle :: X11Property String-getActiveWindowTitle = withActiveWindow getWindowTitle---- | Return a list of all windows-getWindows :: X11Property [X11Window]-getWindows = readAsListOfWindow Nothing "_NET_CLIENT_LIST"---- | Return a list of X11 window handles, one for each window open. Refer to the--- documentation of 'X11WindowHandle' for details on the structure returned.-getWindowHandles :: X11Property [X11WindowHandle]-getWindowHandles = do- windows <- getWindows- workspaces <- mapM getWorkspace windows- wtitles <- mapM getWindowTitle windows- wclasses <- mapM getWindowClass windows- return $ zip (zip3 workspaces wtitles wclasses) windows---- | Return the index (starting from 0) of the workspace on which the--- given window is being displayed.-getWorkspace :: X11Window -> X11Property WorkspaceIdx-getWorkspace window = WSIdx <$> readAsInt (Just window) "_NET_WM_DESKTOP"---- | Ask the window manager to give focus to the given window.-focusWindow :: X11Window -> X11Property ()-focusWindow wh = do- cmd <- getAtom "_NET_ACTIVE_WINDOW"- sendWindowEvent cmd (fromIntegral wh)
− src/System/Information/Memory.hs
@@ -1,54 +0,0 @@-module System.Information.Memory (- MemoryInfo(..),- parseMeminfo- ) where--toMB :: String -> Double-toMB size = (read size :: Double) / 1024--data MemoryInfo = MemoryInfo { memoryTotal :: Double- , memoryFree :: Double- , memoryBuffer :: Double- , memoryCache :: Double- , memorySwapTotal :: Double- , memorySwapFree :: Double- , memorySwapUsed :: Double -- swapTotal - swapFree- , memorySwapUsedRatio :: Double -- swapUsed / swapTotal- , memoryAvailable :: Double -- An estimate of how much memory is available for starting new apps- , memoryRest :: Double -- free + buffer + cache- , memoryUsed :: Double -- total - rest- , memoryUsedRatio :: Double -- used / total- }--emptyMemoryInfo :: MemoryInfo-emptyMemoryInfo = MemoryInfo 0 0 0 0 0 0 0 0 0 0 0 0--parseLines :: [String] -> MemoryInfo -> MemoryInfo-parseLines (line:rest) memInfo = parseLines rest newMemInfo- where (label:size:_) = words line- newMemInfo = case label of- "MemTotal:" -> memInfo { memoryTotal = toMB size }- "MemFree:" -> memInfo { memoryFree = toMB size }- "MemAvailable:" -> memInfo { memoryAvailable = toMB size }- "Buffers:" -> memInfo { memoryBuffer = toMB size }- "Cached:" -> memInfo { memoryCache = toMB size }- "SwapTotal:" -> memInfo { memorySwapTotal = toMB size }- "SwapFree:" -> memInfo { memorySwapFree = toMB size }- _ -> memInfo-parseLines _ memInfo = memInfo--parseMeminfo :: IO MemoryInfo-parseMeminfo = do- s <- readFile "/proc/meminfo"- let m = parseLines (lines s) emptyMemoryInfo- rest = memoryFree m + memoryBuffer m + memoryCache m- used = memoryTotal m - rest- usedRatio = used / memoryTotal m- swapUsed = memorySwapTotal m - memorySwapFree m- swapUsedRatio = swapUsed / memorySwapTotal m- return m { memoryRest = rest- , memoryUsed = used- , memoryUsedRatio = usedRatio- , memorySwapUsed = swapUsed- , memorySwapUsedRatio = swapUsedRatio- }
− src/System/Information/Network.hs
@@ -1,61 +0,0 @@--------------------------------------------------------------------------------- |--- Module : System.Information.Network--- Copyright : (c) José A. Romero L.--- License : BSD3-style (see LICENSE)------ Maintainer : José A. Romero L. <escherdragon@gmail.com>--- Stability : unstable--- Portability : unportable------ Provides information about network traffic over selected interfaces,--- obtained from parsing the @\/proc\/net\/dev@ file using some of the--- facilities provided by the "System.Information.StreamInfo" module.-----------------------------------------------------------------------------------module System.Information.Network ( getNetInfo ) where--import Control.Applicative-import Control.Monad-import Control.Exception (catch, SomeException)-import Data.Maybe ( mapMaybe )-import Safe ( atMay, initSafe, readDef )-import System.Information.StreamInfo ( getParsedInfo )-import Control.Monad.Trans.Maybe (MaybeT(..))--import Prelude---- | Returns a two-element list containing the current number of bytes--- received and transmitted via the given network interface (e.g. \"wlan0\"),--- according to the contents of the @\/proc\/dev\/net@ file.-getNetInfo :: String -> IO (Maybe [Int])-getNetInfo iface = runMaybeT $ do- isInterfaceUp iface- handleFailure $ getParsedInfo "/proc/net/dev" parse iface--parse :: String -> [(String, [Int])]-parse = mapMaybe tuplize . map words . drop 2 . lines--tuplize :: [String] -> Maybe (String, [Int])-tuplize s = do- dev <- initSafe <$> s `atMay` 0- down <- readDef (-1) <$> s `atMay` 1- up <- readDef (-1) <$> s `atMay` out- return (dev, [down, up])- where- out = (length s) - 8---- Nothing if interface does not exist or is down-isInterfaceUp :: String -> MaybeT IO ()-isInterfaceUp iface = do- state <- handleFailure $ readFile $ "/sys/class/net/" ++ iface ++ "/operstate"- case state of- 'u' : _ -> return ()- _ -> mzero--handleFailure :: IO a -> MaybeT IO a-handleFailure action = MaybeT $ catch (Just <$> action) eToNothing- where- eToNothing :: SomeException -> IO (Maybe a)- eToNothing _ = pure Nothing
− src/System/Information/SafeX11.hsc
@@ -1,218 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses, StandaloneDeriving, FlexibleInstances,- InterruptibleFFI, ExistentialQuantification, DeriveDataTypeable #-}--------------------------------------------------------------------------------- |--- Module : System.Information.SafeX11--- Copyright : (c) Ivan A. Malison--- License : BSD3-style (see LICENSE)------ Maintainer : Ivan A. Malison--- Stability : unstable--- Portability : unportable-------------------------------------------------------------------------------module System.Information.SafeX11- ( module Graphics.X11.Xlib- , module Graphics.X11.Xlib.Extras- , module System.Information.SafeX11- )- where--import Control.Concurrent-import Control.Exception-import Control.Monad-import Control.Monad.Trans-import Control.Monad.Trans.Maybe (MaybeT(..))-import Data.Either.Combinators-import Data.Typeable-import Foreign hiding (void)-import Foreign.C.Types-import GHC.ForeignPtr-import Graphics.X11.Xlib-import Graphics.X11.Xlib.Extras- hiding (rawGetWindowProperty, getWindowProperty8,- getWindowProperty16, getWindowProperty32,- xGetWMHints, getWMHints, refreshKeyboardMapping)-import Prelude-import System.IO-import System.IO.Unsafe-import System.Timeout--foreign import ccall safe "XlibExtras.h XGetWMHints"- safeXGetWMHints :: Display -> Window -> IO (Ptr WMHints)--foreign import ccall interruptible "XlibExtras.h XGetWindowProperty"- safeXGetWindowProperty ::- Display ->- Window ->- Atom ->- CLong ->- CLong ->- Bool ->- Atom ->- Ptr Atom ->- Ptr CInt ->- Ptr CULong ->- Ptr CULong ->- Ptr (Ptr CUChar) -> IO Status--rawGetWindowPropertyBytes- :: Storable a- => Int -> Display -> Atom -> Window -> IO (Maybe (ForeignPtr a, Int))-rawGetWindowPropertyBytes bits d atom w =- alloca $ \actual_type_return ->- alloca $ \actual_format_return ->- alloca $ \nitems_return ->- alloca $ \bytes_after_return ->- alloca $ \prop_return -> do- ret <- postX11RequestSync $- safeXGetWindowProperty- d- w- atom- 0- 0xFFFFFFFF- False- anyPropertyType- actual_type_return- actual_format_return- nitems_return- bytes_after_return- prop_return- if fromRight (-1) ret /= 0- then return Nothing- else do- prop_ptr <- peek prop_return- actual_format <- fromIntegral `fmap` peek actual_format_return- nitems <- fromIntegral `fmap` peek nitems_return- getprop prop_ptr nitems actual_format- where- getprop prop_ptr nitems actual_format- | actual_format == 0 = return Nothing -- Property not found- | actual_format /= bits = xFree prop_ptr >> return Nothing- | otherwise = do- ptr <- newConcForeignPtr (castPtr prop_ptr) (void $ xFree prop_ptr)- return $ Just (ptr, nitems)--data SafeX11Exception = SafeX11Exception deriving (Show, Eq, Typeable)--instance Exception SafeX11Exception--data IORequest = forall a. IORequest- { ioAction :: IO a- , ioResponse :: Chan (Either SafeX11Exception a)- }--{-# NOINLINE requestQueue #-}-requestQueue :: Chan IORequest-requestQueue = unsafePerformIO newChan--{-# NOINLINE x11Thread #-}-x11Thread :: ThreadId-x11Thread = unsafePerformIO $ forkIO startHandlingX11Requests--withErrorHandler :: XErrorHandler -> IO a -> IO a-withErrorHandler new_handler action = do- handler <- mkXErrorHandler (\d e -> new_handler d e >> return 0)- original <- _xSetErrorHandler handler- res <- action- _ <- _xSetErrorHandler original- return res--deriving instance Show ErrorEvent--startHandlingX11Requests :: IO ()-startHandlingX11Requests =- withErrorHandler handleError handleX11Requests- where handleError _ xerrptr = do- putStrLn "Got error"- ee <- getErrorEvent xerrptr- print ee--handleX11Requests :: IO ()-handleX11Requests = do- IORequest {ioAction = action, ioResponse = responseChannel} <-- readChan requestQueue- res <-- catch- (maybe (Left SafeX11Exception) Right <$> timeout 500000 action)- (\e -> do- putStrLn "Got error on X11 thread"- hFlush stdout- print (e :: IOException)- return $ Left SafeX11Exception)- writeChan responseChannel res- handleX11Requests- return ()--postX11RequestSync :: IO a -> IO (Either SafeX11Exception a)-postX11RequestSync action = do- let postAndWait = do- responseChannel <- newChan :: IO (Chan (Either SafeX11Exception a))- writeChan- requestQueue- IORequest {ioAction = action, ioResponse = responseChannel}- readChan responseChannel- currentTID <- myThreadId- if currentTID == x11Thread- then Right <$> action- else postAndWait--postX11RequestSyncDef :: a -> IO a -> IO a-postX11RequestSyncDef def action =- fromRight def <$> postX11RequestSync action--rawGetWindowProperty ::- Storable a- => Int -> Display -> Atom -> Window -> IO (Maybe [a])-rawGetWindowProperty bits d atom w =- runMaybeT $ do- (ptr, count) <- MaybeT $ rawGetWindowPropertyBytes bits d atom w- lift $ withForeignPtr ptr $ peekArray count--getWindowProperty8 :: Display -> Atom -> Window -> IO (Maybe [CChar])-getWindowProperty8 = rawGetWindowProperty 8--getWindowProperty16 :: Display -> Atom -> Window -> IO (Maybe [CShort])-getWindowProperty16 = rawGetWindowProperty 16--getWindowProperty32 :: Display -> Atom -> Window -> IO (Maybe [CLong])-getWindowProperty32 = rawGetWindowProperty 32--getWMHints :: Display -> Window -> IO WMHints-getWMHints dpy w = do- p <- safeXGetWMHints dpy w- if p == nullPtr- then return $ WMHints 0 False 0 0 0 0 0 0 0- else do x <- peek p; _ <- xFree p; return x--safeGetGeometry :: Display -> Drawable ->- IO (Window, Position, Position, Dimension, Dimension, Dimension, CInt)-safeGetGeometry display d =- outParameters7 (throwIfZero "getGeometry") $- xGetGeometry display d--outParameters7 :: (Storable a, Storable b, Storable c, Storable d, Storable e, Storable f, Storable g) =>- (IO r -> IO ()) -> (Ptr a -> Ptr b -> Ptr c -> Ptr d -> Ptr e -> Ptr f -> Ptr g -> IO r) ->- IO (a,b,c,d,e,f,g)-outParameters7 check fn =- alloca $ \ a_return ->- alloca $ \ b_return ->- alloca $ \ c_return ->- alloca $ \ d_return ->- alloca $ \ e_return ->- alloca $ \ f_return ->- alloca $ \ g_return -> do- check (fn a_return b_return c_return d_return e_return f_return g_return)- a <- peek a_return- b <- peek b_return- c <- peek c_return- d <- peek d_return- e <- peek e_return- f <- peek f_return- g <- peek g_return- return (a,b,c,d,e,f,g)--foreign import ccall safe "HsXlib.h XGetGeometry"- xGetGeometry :: Display -> Drawable ->- Ptr Window -> Ptr Position -> Ptr Position -> Ptr Dimension ->- Ptr Dimension -> Ptr Dimension -> Ptr CInt -> IO Status
− src/System/Information/StreamInfo.hs
@@ -1,90 +0,0 @@------------------------------------------------------------------------------------ |--- Module : System.Information.StreamInfo--- Copyright : (c) José A. Romero L.--- License : BSD3-style (see LICENSE)------ Maintainer : José A. Romero L. <escherdragon@gmail.com>--- Stability : unstable--- Portability : unportable------ Generic code to poll any of the many data files maintained by the kernel in--- POSIX systems. Provides methods for applying a custom parsing function to the--- contents of the file and to calculate differentials across one or more values--- provided via the file.--------------------------------------------------------------------------------------module System.Information.StreamInfo- ( getParsedInfo- , getLoad- , getAccLoad- , getTransfer- ) where--import Control.Concurrent ( threadDelay )-import Data.IORef-import Data.Maybe ( fromMaybe )---- | Apply the given parser function to the file under the given path to produce--- a lookup map, then use the given selector as key to extract from it the--- desired value.-getParsedInfo :: FilePath -> (String -> [(String, [a])]) -> String -> IO [a]-getParsedInfo path parser selector = do- file <- readFile path- (length file) `seq` return ()- return (fromMaybe [] $ lookup selector $ parser file)--truncVal :: (RealFloat a) => a -> a-truncVal v- | isNaN v || v < 0.0 = 0.0- | otherwise = v---- | Convert the given list of Integer to a list of the ratios of each of its--- elements against their sum.-toRatioList :: (Integral a, RealFloat b) => [a] -> [b]-toRatioList deltas = map truncVal ratios- where total = fromIntegral $ foldr (+) 0 deltas- ratios = map ((/total) . fromIntegral) deltas---- | Execute the given action twice with the given delay in-between and return--- the difference between the two samples.-probe :: (Num a, RealFrac b) => IO [a] -> b -> IO [a]-probe action delay = do- a <- action- threadDelay $ round (delay * 1e6)- b <- action- return $ zipWith (-) b a---- | Execute the given action once and return the difference between the--- obtained sample and the one contained in the given IORef.-accProbe :: (Num a) => IO [a] -> IORef [a] -> IO [a]-accProbe action sample = do- a <- readIORef sample- b <- action- writeIORef sample b- return $ zipWith (-) b a---- | Probe the given action and, interpreting the result as a variation in time,--- return the speed of change of its values.-getTransfer :: (Integral a, RealFloat b) => b -> IO [a] -> IO [b]-getTransfer interval action = do- deltas <- probe action interval- return $ map (truncVal . (/interval) . fromIntegral) deltas---- | Probe the given action and return the relative variation of each of the--- obtained values against the whole, where the whole is calculated as the sum--- of all the values in the probe.-getLoad :: (Integral a, RealFloat b) => b -> IO [a] -> IO [b]-getLoad interval action = do- deltas <- probe action interval- return $ toRatioList deltas---- | Similar to getLoad, but execute the given action only once and use the--- given IORef to calculate the result and to save the current value, so it--- can be reused in the next call.-getAccLoad :: (Integral a, RealFloat b) => IORef [a] -> IO [a] -> IO [b]-getAccLoad sample action = do- deltas <- accProbe action sample- return $ toRatioList deltas-
− src/System/Information/Volume.hs
@@ -1,38 +0,0 @@-module System.Information.Volume (- getVolume,- setVolume-) where--import Sound.ALSA.Mixer---- | Gets volume of a channel of a mixer-getVolume :: String -> String -> IO Integer-getVolume mix channel = withMixer mix $ \mixer -> do- Just control <- getControlByName mixer channel- let Just playbackVolume = playback $ volume control- (lo, hi) <- getRange playbackVolume- Just vol <- getChannel FrontLeft $ value playbackVolume- return $ toPercent vol lo hi---- | Sets volume of a channel of a mixer-setVolume :: String -> String -> Double -> IO ()-setVolume mix channel vol = withMixer mix $ \mixer -> do- Just control <- getControlByName mixer channel- let Just playbackVolume = playback $ volume control- (lo, hi) <- getRange playbackVolume- setChannel FrontLeft (value playbackVolume) $ fromPercent vol lo hi- setChannel FrontRight (value playbackVolume) $ fromPercent vol lo hi- setChannel RearLeft (value playbackVolume) $ fromPercent vol lo hi- setChannel RearRight (value playbackVolume) $ fromPercent vol lo hi- setChannel FrontCenter (value playbackVolume) $ fromPercent vol lo hi--toPercent :: Integer -> Integer -> Integer -> Integer-toPercent v lo hi = ceiling $ (v' - lo') / (hi' - lo') * 100- where v' = fromIntegral v- lo' = fromIntegral lo- hi' = fromIntegral hi--fromPercent :: Double -> Integer -> Integer -> Integer-fromPercent v lo hi = ceiling $ lo' + (hi' - lo') * v / 100- where lo' = fromIntegral lo- hi' = fromIntegral hi
− src/System/Information/X11DesktopInfo.hs
@@ -1,282 +0,0 @@--------------------------------------------------------------------------------- |--- Module : System.Information.X11DesktopInfo--- Copyright : (c) José A. Romero L.--- License : BSD3-style (see LICENSE)------ Maintainer : José A. Romero L. <escherdragon@gmail.com>--- Stability : unstable--- Portability : unportable------ Low-level functions to access data provided by the X11 desktop via window--- properties. One of them ('getVisibleTags') depends on the PagerHints hook--- being installed in your @~\/.xmonad\/xmonad.hs@ configuration:------ > import System.Taffybar.Hooks.PagerHints (pagerHints)--- >--- > main = xmonad $ ewmh $ pagerHints $ ...-----------------------------------------------------------------------------------module System.Information.X11DesktopInfo- ( X11Context(..)- , X11Property- , X11Window- , withDefaultCtx- , getDefaultCtx- , getWindowState- , getWindowStateProperty- , readAsInt- , readAsListOfInt- , readAsString- , readAsListOfString- , readAsListOfWindow- , isWindowUrgent- , getVisibleTags- , getAtom- , getDisplay- , eventLoop- , sendCommandEvent- , sendWindowEvent- , postX11RequestSyncProp- , getPrimaryOutputNumber- ) where--import Data.List-import Data.Maybe--import Codec.Binary.UTF8.String as UTF8-import qualified Control.Concurrent.MVar as MV-import Control.Monad.Reader-import Data.Bits (testBit, (.|.))-import Data.List.Split (endBy)-import Graphics.X11.Xlib-import Graphics.X11.Xlib.Extras- hiding (rawGetWindowProperty, getWindowProperty8,- getWindowProperty16, getWindowProperty32,- getWMHints)-import Graphics.X11.Xrandr-import Prelude-import System.Information.SafeX11--data X11Context = X11Context- { contextDisplay :: Display- , _contextRoot :: Window- , atomCache :: MV.MVar [(String, Atom)]- }-type X11Property a = ReaderT X11Context IO a-type X11Window = Window-type PropertyFetcher a = Display -> Atom -> Window -> IO (Maybe [a])---- | Put the current display and root window objects inside a Reader--- transformer for further computation.-withDefaultCtx :: X11Property a -> IO a-withDefaultCtx fun = do- ctx <- getDefaultCtx- res <- runReaderT fun ctx- closeDisplay (contextDisplay ctx)- return res--getDisplay :: X11Property Display-getDisplay = contextDisplay <$> ask---- | Retrieve the property of the given window (or the root window,--- if Nothing) with the given name as a value of type Int. If that--- property hasn't been set, then return -1.-readAsInt :: Maybe X11Window -- ^ window to read from. Nothing means the root window.- -> String -- ^ name of the property to retrieve- -> X11Property Int-readAsInt window name = do- prop <- fetch getWindowProperty32 window name- case prop of- Just (x:_) -> return (fromIntegral x)- _ -> return (-1)---- | Retrieve the property of the given window (or the root window,--- if Nothing) with the given name as a list of Ints. If that--- property hasn't been set, then return an empty list.-readAsListOfInt :: Maybe X11Window -- ^ window to read from. Nothing means the root window.- -> String -- ^ name of the property to retrieve- -> X11Property [Int]-readAsListOfInt window name = do- prop <- fetch getWindowProperty32 window name- case prop of- Just xs -> return (map fromIntegral xs)- _ -> return []---- | Retrieve the property of the given window (or the root window,--- if Nothing) with the given name as a String. If the property--- hasn't been set, then return an empty string.-readAsString :: Maybe X11Window -- ^ window to read from. Nothing means the root window.- -> String -- ^ name of the property to retrieve- -> X11Property String-readAsString window name = do- prop <- fetch getWindowProperty8 window name- case prop of- Just xs -> return . UTF8.decode . map fromIntegral $ xs- _ -> return []---- | Retrieve the property of the given window (or the root window,--- if Nothing) with the given name as a list of Strings. If the--- property hasn't been set, then return an empty list.-readAsListOfString :: Maybe X11Window -- ^ window to read from. Nothing means the root window.- -> String -- ^ name of the property to retrieve- -> X11Property [String]-readAsListOfString window name = do- prop <- fetch getWindowProperty8 window name- case prop of- Just xs -> return (parse xs)- _ -> return []- where- parse = endBy "\0" . UTF8.decode . map fromIntegral---- | Retrieve the property of the given window (or the root window,--- if Nothing) with the given name as a list of X11 Window IDs. If--- the property hasn't been set, then return an empty list.-readAsListOfWindow :: Maybe X11Window -- ^ window to read from. Nothing means the root window.- -> String -- ^ name of the property to retrieve- -> X11Property [X11Window]-readAsListOfWindow window name = do- prop <- fetch getWindowProperty32 window name- case prop of- Just xs -> return $ map fromIntegral xs- _ -> return []---- | Determine whether the \"urgent\" flag is set in the WM_HINTS of--- the given window.-isWindowUrgent :: X11Window -> X11Property Bool-isWindowUrgent window = do- hints <- fetchWindowHints window- return $ testBit (wmh_flags hints) urgencyHintBit---- | Retrieve the value of the special _XMONAD_VISIBLE_WORKSPACES hint set--- by the PagerHints hook provided by Taffybar (see module documentation for--- instructions on how to do this), or an empty list of strings if the--- PagerHints hook is not available.-getVisibleTags :: X11Property [String]-getVisibleTags = readAsListOfString Nothing "_XMONAD_VISIBLE_WORKSPACES"---- | Return the Atom with the given name.-getAtom :: String -> X11Property Atom-getAtom s = do- (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--- arrives, and subscribing to all events of this type emitted by newly--- created windows.-eventLoop :: (Event -> IO ()) -> X11Property ()-eventLoop dispatch = do- (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 { ev_window = window } ->- selectInput d window propertyChangeMask- _ -> return ()- dispatch event---- | Emit a \"command\" event with one argument for the X server. This is--- used to send events that can be received by event hooks in the XMonad--- process and acted upon in that context.-sendCommandEvent :: Atom -> Atom -> X11Property ()-sendCommandEvent cmd arg = do- (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- sendCustomEvent dpy cmd cmd root win---- | Build a new X11Context containing the current X11 display and its root--- window.-getDefaultCtx :: IO X11Context-getDefaultCtx = do- d <- openDisplay ""- w <- rootWindow d $ defaultScreen d- cache <- MV.newMVar []- return $ X11Context d w cache--getWindowStateProperty :: X11Window -> String -> X11Property Bool-getWindowStateProperty window property = not . null <$> getWindowState window [property]--getWindowState :: X11Window -> [String] -> X11Property [String]-getWindowState window request = do- let getAsLong s = fromIntegral <$> getAtom s- integers <- mapM getAsLong request- properties <- fetch getWindowProperty32 (Just window) "_NET_WM_STATE"- let integerToString = zip integers request- present = intersect integers $ fromMaybe [] properties- presentStrings = map (`lookup` integerToString) present- return $ catMaybes presentStrings---- | Apply the given function to the given window in order to obtain the X11--- property with the given name, or Nothing if no such property can be read.-fetch :: (Integral a)- => PropertyFetcher a -- ^ Function to use to retrieve the property.- -> Maybe X11Window -- ^ Window to read from. Nothing means the root Window.- -> String -- ^ Name of the property to retrieve.- -> X11Property (Maybe [a])-fetch fetcher window name = do- (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- liftIO $ getWMHints d window---- | Emit an event of type @ClientMessage@ that can be listened to and--- consumed by XMonad event hooks.-sendCustomEvent :: Display- -> Atom- -> Atom- -> X11Window- -> X11Window- -> X11Property ()-sendCustomEvent dpy cmd arg root win =- liftIO $ allocaXEvent $ \e -> do- setEventType e clientMessage- setClientMessageEvent e win cmd 32 arg currentTime- sendEvent dpy root False structureNotifyMask e- sync dpy False--postX11RequestSyncProp :: X11Property a -> a -> X11Property a-postX11RequestSyncProp prop def = do- c <- ask- let action = runReaderT prop c- lift $ postX11RequestSyncDef def action--isActiveOutput :: XRRScreenResources -> RROutput -> X11Property Bool-isActiveOutput sres output = do- (X11Context display _ _) <- ask- maybeOutputInfo <- liftIO $ xrrGetOutputInfo display sres output- return $ maybe 0 xrr_oi_crtc maybeOutputInfo /= 0--getActiveOutputs :: X11Property [RROutput]-getActiveOutputs = do- (X11Context display rootw _) <- ask- maybeSres <- liftIO $ xrrGetScreenResources display rootw- maybe (return []) (\sres -> filterM (isActiveOutput sres) $ xrr_sr_outputs sres)- maybeSres---- | Get the index of the primary monitor as set and ordered by Xrandr.-getPrimaryOutputNumber :: X11Property (Maybe Int)-getPrimaryOutputNumber = do- (X11Context display rootw _) <- ask- primary <- liftIO $ xrrGetOutputPrimary display rootw- outputs <- getActiveOutputs- return $ primary `elemIndex` outputs
src/System/Taffybar.hs view
@@ -1,42 +1,48 @@--- | The main module of Taffybar-module System.Taffybar (+-----------------------------------------------------------------------------+-- |+-- Module : System.Taffybar+-- Copyright : (c) Ivan A. Malison+-- License : BSD3-style (see LICENSE)+--+-- Maintainer : Ivan A. Malison+-- Stability : unstable+-- Portability : unportable+-----------------------------------------------------------------------------+module System.Taffybar+ ( -- * Detail --- -- | This is a system status bar meant for use with window manager- -- like XMonad. It is similar to xmobar, but with more visual flare- -- and a different widget set. Contributed widgets are more than- -- welcome. The bar is drawn using gtk and cairo. It is actually- -- the simplest possible thing that could plausibly work: you give- -- Taffybar a list of GTK widgets and it will render them in a- -- horizontal bar for you (taking care of ugly details like- -- reserving strut space so that window managers don't put windows- -- over it).+ -- | This is a system status bar meant for use with window managers like+ -- XMonad. It is similar to xmobar, but with more visual flare and a different+ -- widget set. Contributed widgets are more than welcome. The bar is drawn+ -- using gtk and cairo. It is actually the simplest possible thing that could+ -- plausibly work: you give Taffybar a list of GTK widgets and it will render+ -- them in a horizontal bar for you (taking care of ugly details like+ -- reserving strut space so that window managers don't put windows over it). --- -- This is the real main module. The default bar should be- -- customized to taste in the config file- -- (~/.config/taffybar/taffybar.hs). Typically, this means adding- -- widgets to the default config. A default configuration file is- -- included in the distribution, but the essentials are covered- -- here.+ -- This is the real main module. The default bar should be customized to taste+ -- in the config file (~/.config/taffybar/taffybar.hs). Typically, this means+ -- adding widgets to the default config. A default configuration file is+ -- included in the distribution, but the essentials are covered here. -- * Config File --- -- | The config file is just a Haskell source file that is compiled- -- at startup (if it has changed) to produce a custom executable- -- with the desired set of widgets. You will want to import this- -- module along with the modules of any widgets you want to add to- -- the bar. Note, you can define any widgets that you want in your- -- config file or other libraries. Taffybar only cares that you- -- give it some GTK widgets to display.+ -- | The config file is just a Haskell source file that is compiled at startup+ -- (if it has changed) to produce a custom executable with the desired set of+ -- widgets. You will want to import this module along with the modules of any+ -- widgets you want to add to the bar. Note, you can define any widgets that+ -- you want in your config file or other libraries. Taffybar only cares that+ -- you give it some GTK widgets to display. -- -- Below is a fairly typical example: -- -- > import System.Taffybar- -- > import System.Taffybar.Systray- -- > import System.Taffybar.XMonadLog- -- > import System.Taffybar.SimpleClock- -- > import System.Taffybar.Widgets.PollingGraph- -- > import System.Information.CPU+ -- > import System.Taffybar.SimpleConfig+ -- > import System.Taffybar.Widget.Systray+ -- > import System.Taffybar.Widget.Workspaces+ -- > import System.Taffybar.Widget.SimpleClock+ -- > import System.Taffybar.Widget.Generic.PollingGraph+ -- > import System.Taffybar.Information.CPU -- > -- > cpuCallback = do -- > (_, systemLoad, totalLoad) <- cpuLoad@@ -47,269 +53,98 @@ -- > , graphLabel = Just "cpu" -- > } -- > clock = textClockNew Nothing "<span fgcolor='orange'>%a %b %_d %H:%M</span>" 1- -- > log = xmonadLogNew -- > tray = systrayNew -- > cpu = pollingGraphNew cpuCfg 0.5 cpuCallback- -- > defaultTaffybar defaultTaffybarConfig { startWidgets = [ log ]- -- > , endWidgets = [ tray, clock, cpu ]- -- > }- --- -- This configuration creates a bar with four widgets. On the left is- -- the XMonad log. The rightmost widget is the system tray, with a- -- clock and then a CPU graph. The clock is formatted using standard- -- strftime-style format strings (see the clock module). Note that- -- the clock is colored using Pango markup (again, see the clock- -- module).- --- -- The CPU widget plots two graphs on the same widget: total CPU use- -- in green and then system CPU use in a kind of semi-transparent- -- purple on top of the green.+ -- > workspacs = workspacesNew defaultWorkspacesConfig+ -- > simpleConfig = defaultSimpleTaffyConfig+ -- > { startWidgets = [ workspaces ]+ -- > , endWidgets = [ tray, clock, cpu ]+ -- > }+ -- > simpleTaffybar simpleConfig --- -- It is important to note that the widget lists are *not* [Widget].- -- They are actually [IO Widget] since the bar needs to construct them- -- after performing some GTK initialization.-- -- * XMonad Integration (via DBus)+ -- This configuration creates a bar with four widgets. On the left is a widget+ -- that shows information about the workspace configuration. The rightmost+ -- widget is the system tray, with a clock and then a CPU graph. The clock is+ -- formatted using standard strftime-style format strings (see the clock+ -- module). Note that the clock is colored using Pango markup (again, see the+ -- clock module). --- -- | The XMonadLog widget differs from its counterpart in xmobar: it- -- listens for updates over DBus instead of reading from stdin.- -- This makes it easy to restart Taffybar independently of XMonad.- -- XMonad does not come with a DBus logger, so here is an example of- -- how to make it work. Note: this requires the dbus-core (>0.9)- -- package, which is installed as a dependency of Taffybar.+ -- The CPU widget plots two graphs on the same widget: total CPU use in green+ -- and then system CPU use in a kind of semi-transparent purple on top of the+ -- green. --- -- > import XMonad.Hooks.DynamicLog- -- > import XMonad.Hooks.ManageDocks- -- > import DBus.Client- -- > import System.Taffybar.XMonadLog ( dbusLog )- -- >- -- > main = do- -- > client <- connectSession- -- > let pp = defaultPP- -- > xmonad $ docks defaultConfig { logHook = dbusLog client pp }+ -- It is important to note that the widget lists are *not* [Widget]. They are+ -- actually [IO Widget] since the bar needs to construct them after performing+ -- some GTK initialization. --- -- The complexity is handled in the System.Taffybar.XMonadLog module. Note- -- that the docks wrapper from ManageDocks is required to have XMonad put- -- taffybar in the strut space that it reserves. If you have problems with- -- taffybar appearing almost fullscreen, check to see if you are using this- -- wrapper. Note that the manageDocks hook that previous used to be sufficient- -- for this is no longer so (see- -- https://github.com/travitch/taffybar/issues/185).-- -- ** A note about DBus:+ -- ** A note about taffybar's dependency on DBus: -- |- -- * If you start xmonad using a graphical login manager like gdm or- -- kdm, DBus should be started automatically for you.+ -- * If you start your window manager using a graphical login manager like gdm+ -- or kdm, DBus should be started automatically for you. --- -- * If you start xmonad with a different graphical login manager that- -- does not start DBus for you automatically, put the line @eval- -- \`dbus-launch --auto-syntax\`@ into your ~\/.xsession *before*- -- xmonad and taffybar are started. This command sets some- -- environment variables that the two must agree on.+ -- * If you start xmonad with a different graphical login manager that does+ -- not start DBus for you automatically, put the line @eval \`dbus-launch+ -- --auto-syntax\`@ into your ~\/.xsession *before* xmonad and taffybar are+ -- started. This command sets some environment variables that the two must+ -- agree on. -- -- * If you start xmonad via @startx@ or a similar command, add the -- above command to ~\/.xinitrc -- * Colors --- -- | While taffybar is based on GTK+, it ignores your GTK+ theme.- -- The default theme that it uses is in- -- @~\/.cabal\/share\/taffybar-\<version\>\/taffybar.rc@. You can- -- customize this theme by copying it to- -- @~\/.config\/taffybar\/taffybar.rc@. For an idea of the customizations you can make,- -- see <https://live.gnome.org/GnomeArt/Tutorials/GtkThemes>.-- -- * Advanced Widget Example- --- -- | The following is an example leveraging GTK+ features that are not exposed- -- by the normal Taffybar widget hooks.- --- -- > import qualified Graphics.UI.Gtk as Gtk- -- > import System.Taffybar.Widgets.PollingGraph- -- > import System.Information.CPU- -- > import XMonad.Util.Run- -- >- -- > main = do- -- > let- -- > cpuReader widget = do- -- > (userLoad, systemLoad, totalLoad) <- cpuLoad- -- > Gtk.postGUIAsync $ do- -- > let- -- > user = round $ 100 * userLoad :: Int- -- > system = round $ 100 * systemLoad :: Int- -- > tooltip = printf "%02i%% User\n%02i%% System" user system :: String- -- > _ <- Gtk.widgetSetTooltipText widget $ Just tooltip- -- > return ()- -- > return [totalLoad, systemLoad]- -- >- -- > cpuButtons = do- -- > e <- Gtk.eventButton- -- > case e of- -- > Gtk.LeftButton -> unsafeSpawn "terminator -e glances"- -- > Gtk.RightButton -> unsafeSpawn "terminator -e top"- -- > Gtk.MiddleButton -> unsafeSpawn "gnome-system-monitor"- -- > _ -> return ()- -- > return True- -- >- -- > cpuCfg = defaultGraphConfig { graphDataColors = [ (0, 1, 0, 1)- -- > , (1, 0, 1, 0.5)- -- > ]- -- > }- -- >- -- >- -- > cpu = do- -- > ebox <- Gtk.eventBoxNew- -- > btn <- pollingGraphNew cpuCfg 0.5 $ cpuReader $ Gtk.toWidget ebox- -- > Gtk.containerAdd ebox btn- -- > _ <- Gtk.on ebox Gtk.buttonPressEvent systemEvents- -- > Gtk.widgetShowAll ebox- -- > return $ Gtk.toWidget ebox- --- -- The resulting widget can be used like normal widgets, but you can use- -- different mouse buttons to run various programs and it has a useful tooltip- -- which shows the concrete numbers, which may not be clear in the graph- -- itself.-- TaffybarConfig(..),- TaffybarConfigEQ,- defaultTaffybar,- defaultTaffybarConfig,- Position(..),- taffybarMain,- allMonitors,- useMonitorNumber,- realMain,- usePrimaryMonitor,+ -- | While taffybar is based on GTK+, it ignores your GTK+ theme. The default+ -- theme that it uses lives at+ -- https://github.com/taffybar/taffybar/blob/master/taffybar.css You can alter+ -- this theme by editing @~\/.config\/taffybar\/taffybar.css@ to your liking.+ -- For an idea of the customizations you can make, see+ -- <https://live.gnome.org/GnomeArt/Tutorials/GtkThemes>.+ taffybarDyreParams+ , dyreTaffybar+ , startTaffybar+ , dyreTaffybarMain ) where import qualified Config.Dyre as Dyre import qualified Config.Dyre.Params as Dyre-import qualified Control.Concurrent.MVar as MV-import Control.Monad ( when, foldM, void )-import Data.List-import qualified Data.Map as M-import Data.Maybe ( fromMaybe )+import Control.Monad import Graphics.UI.Gtk as Gtk-import Graphics.UI.Gtk.General.StyleContext+import Graphics.UI.Gtk.General.CssProvider+import qualified Graphics.UI.Gtk.General.StyleContext as Gtk import Graphics.X11.Xlib.Misc-import Safe ( atMay ) import System.Directory import System.Environment.XDG.BaseDir ( getUserConfigFile ) import System.Exit ( exitFailure ) import System.FilePath ( (</>) )-import System.Information.X11DesktopInfo import qualified System.IO as IO-import System.Mem.StableName-import Text.Printf ( printf )+import System.Taffybar.Context -import Graphics.UI.Gtk.General.CssProvider import Paths_taffybar ( getDataDir )-import System.Taffybar.StrutProperties -data Position = Top | Bottom- deriving (Show, Eq)--strutProperties :: Position -- ^ Bar position- -> Int -- ^ Bar height- -> Rectangle -- ^ Current monitor rectangle- -> [Rectangle] -- ^ All monitors- -> StrutProperties-strutProperties pos bh (Rectangle mX mY mW mH) monitors =- propertize pos sX sW sH- where sX = mX- sW = mW - 1- sH = case pos of Top -> bh + mY- Bottom -> bh + totalH - mY - mH- totalH = maximum $ map bottomY monitors- bottomY (Rectangle _ y _ h) = y + h- propertize p x w h = case p of- Top -> (0, 0, h, 0, 0, 0, 0, 0, x, x+w, 0, 0)- Bottom -> (0, 0, 0, h, 0, 0, 0, 0, 0, 0, x, x+w)--data TaffybarConfig =- TaffybarConfig { -- | The screen number to run the bar on (default is almost always fine)- screenNumber :: Int- -- | The xinerama/xrandr monitor number to put the bar on (default: 0)- , monitorNumber :: Int- -- | Provides a way to specify which screens taffybar should appear on.- , getMonitorConfig :: TaffybarConfigEQ -> IO (Int -> Maybe TaffybarConfigEQ)- -- | A function providing a way to call back in to taffybar to- -- refresh its configs/open closed state on each monitor.- , startRefresher :: IO () -> IO ()- -- | Number of pixels to reserve for the bar (default: 25 pixels)- , barHeight :: Int- -- | Number of additional pixels to reserve for the bar strut (default: 0)- , barPadding :: Int- -- | The position of the bar on the screen (default: Top)- , barPosition :: Position- -- | The number of pixels between widgets- , widgetSpacing :: Int- -- | Used by the application- , errorMsg :: Maybe String- -- | Widgets that are packed in order at the left end of the bar- , startWidgets :: [IO Widget]- -- | Widgets that are packed from right-to-left in the bar- , endWidgets :: [IO Widget]- }--type TaffybarConfigEQ = (TaffybarConfig, StableName TaffybarConfig)---- | The default configuration gives an empty bar 25 pixels high on monitor 0.-defaultTaffybarConfig :: TaffybarConfig-defaultTaffybarConfig =- TaffybarConfig { screenNumber = 0- , monitorNumber = 0- , getMonitorConfig = useMonitorNumber- , startRefresher = const $ return ()- , barHeight = 25- , barPadding = 0- , barPosition = Top- , widgetSpacing = 10- , errorMsg = Nothing- , startWidgets = []- , endWidgets = []- }--useMonitorNumber :: TaffybarConfigEQ -> IO (Int -> Maybe TaffybarConfigEQ)-useMonitorNumber c@(cfg, _) = return umn- where umn mnumber- | mnumber == monitorNumber cfg = Just c- | otherwise = Nothing---- | Use the primary monitor as set by Xrandr.-usePrimaryMonitor :: TaffybarConfigEQ -> IO (Int -> Maybe TaffybarConfigEQ)-usePrimaryMonitor c@(cfg, _) = do- maybePrimary <- withDefaultCtx getPrimaryOutputNumber- let primary = fromMaybe (monitorNumber cfg) maybePrimary- return $ \mnumber -> if mnumber == primary then Just c else Nothing--allMonitors :: TaffybarConfigEQ -> IO (Int -> Maybe TaffybarConfigEQ)-allMonitors cfg = return $ const $ Just cfg--showError :: TaffybarConfig -> String -> TaffybarConfig-showError cfg msg = cfg { errorMsg = Just msg }---- | The default parameters need to tell GHC to compile using--- -threaded so that the GTK event loops doesn't block all of the--- widgets-defaultParams :: Dyre.Params TaffybarConfig-defaultParams =+-- | The parameters that are passed to Dyre when taffybar is invoked with+-- 'dyreTaffybar'.+taffybarDyreParams :: Dyre.Params TaffybarConfig+taffybarDyreParams = Dyre.defaultParams { Dyre.projectName = "taffybar"- , Dyre.realMain = realMain+ , Dyre.realMain = dyreTaffybarMain , Dyre.showError = showError , Dyre.ghcOpts = ["-threaded", "-rtsopts"] , Dyre.rtsOptsHandling = Dyre.RTSAppend ["-I0", "-V0"] } --- | The entry point of the application. Feed it a custom config.-defaultTaffybar :: TaffybarConfig -> IO ()-defaultTaffybar = Dyre.wrapMain defaultParams+-- | Use Dyre to configure and start taffybar. This will automatically recompile+-- taffybar whenever there are changes to your taffybar.hs configuration file.+dyreTaffybar :: TaffybarConfig -> IO ()+dyreTaffybar = Dyre.wrapMain taffybarDyreParams -realMain :: TaffybarConfig -> IO ()-realMain cfg =+showError :: TaffybarConfig -> String -> TaffybarConfig+showError cfg msg = cfg { errorMsg = Just msg }++dyreTaffybarMain :: TaffybarConfig -> IO ()+dyreTaffybarMain cfg = case errorMsg cfg of- Nothing -> taffybarMain cfg+ Nothing -> startTaffybar cfg Just err -> do IO.hPutStrLn IO.stderr ("Error: " ++ err) exitFailure@@ -319,54 +154,6 @@ dataDir <- getDataDir return (dataDir </> name) --- | Given a Taffybar configuration and the Taffybar window, this--- action sets up the window size and strut properties. May be called--- multiple times, e.g., when the monitor resolution changes.-setTaffybarSize :: TaffybarConfig -> Window -> Int -> IO ()-setTaffybarSize cfg window monNumber = do- screen <- windowGetScreen window- nmonitors <- screenGetNMonitors screen- allMonitorSizes <-- mapM (screenGetMonitorGeometry screen) [0 .. (nmonitors - 1)]- when (monNumber >= nmonitors) $- IO.hPutStrLn IO.stderr $- printf- "Monitor %d is not available in the selected screen"- monNumber- let monitorSize =- fromMaybe (head allMonitorSizes) $- allMonitorSizes `atMay` monNumber- let Rectangle x y w h = monitorSize- strutHeight = barHeight cfg + (2 * barPadding cfg)- yoff =- case barPosition cfg of- Top -> barPadding cfg- Bottom -> h - strutHeight- windowMove window x (y + yoff)- -- Set up the window size using fixed min and max sizes. This- -- prevents the contained horizontal box from affecting the window- -- size.- windowSetGeometryHints- window- (Nothing :: Maybe Widget)- (Just (w, barHeight cfg)) -- Min size.- (Just (w, barHeight cfg)) -- Max size.- Nothing- Nothing- Nothing- let setStrutProps =- setStrutProperties window $- strutProperties- (barPosition cfg)- strutHeight- monitorSize- allMonitorSizes-- winRealized <- widgetGetRealized window- if winRealized- then setStrutProps- else void $ on window realize setStrutProps- startCSS :: IO CssProvider startCSS = do -- Override the default GTK theme path settings. This causes the@@ -375,103 +162,25 @@ -- Users can override this default. taffybarProvider <- cssProviderNew let loadIfExists filePath =- doesFileExist filePath >>= flip when (cssProviderLoadFromPath taffybarProvider filePath)+ doesFileExist filePath >>=+ flip when (cssProviderLoadFromPath taffybarProvider filePath) loadIfExists =<< getDefaultConfigFile "taffybar.css" loadIfExists =<< getUserConfigFile "taffybar" "taffybar.css" Just scr <- screenGetDefault- styleContextAddProviderForScreen scr taffybarProvider 800+ Gtk.styleContextAddProviderForScreen scr taffybarProvider 800 return taffybarProvider -taffybarMain :: TaffybarConfig -> IO ()-taffybarMain cfg = do-+-- | 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'+-- instead. If automatic recompilation is handled by another mechanism, or not+-- desired for some reason, it is perfectly fine to use this function.+startTaffybar :: TaffybarConfig -> IO ()+startTaffybar config = do _ <- initThreads _ <- initGUI _ <- startCSS-- Just disp <- displayGetDefault- nscreens <- displayGetNScreens disp- screen <- if screenNumber cfg < nscreens- then displayGetScreen disp (screenNumber cfg)- else error $ printf "Screen %d is not available in the default display"- (screenNumber cfg)-- cfgEq <- makeStableName cfg- taffyWindowsVar <- MV.newMVar M.empty-- let refreshTaffyWindows = do- nmonitors <- screenGetNMonitors screen- getConfig <- getMonitorConfig cfg (cfg, cfgEq)- MV.modifyMVar_ taffyWindowsVar $ \monitorToWindow ->- do- let monitors = union [0 .. (nmonitors - 1)] $ M.keys monitorToWindow- updateBarOnWindow mapToUpdate monNum- | monNum >= nmonitors = maybeDeleteWindow- | otherwise = case M.lookup monNum monitorToWindow of- Just (currentConfig, window) ->- case getConfig monNum of- Just configEq@(_, newConfigEq) ->- if currentConfig == newConfigEq- then- return mapToUpdate- else- widgetDestroy window >>- makeAndAddWindow configEq- Nothing -> maybeDeleteWindow- Nothing ->- case getConfig monNum of- Just configEq -> makeAndAddWindow configEq- Nothing -> return mapToUpdate- where makeAndAddWindow (newConfig, eqcfg) =- do- window <- makeTaffyWindow newConfig monNum- return $ M.insert monNum (eqcfg, window) mapToUpdate- deleteWindow (_, window) =- widgetDestroy window >> return (M.delete monNum mapToUpdate)- maybeDeleteWindow = maybe (return mapToUpdate) deleteWindow $- M.lookup monNum mapToUpdate- foldM updateBarOnWindow monitorToWindow monitors-- makeTaffyWindow wcfg monNumber = do- window <- windowNew- let windowName = printf "Taffybar-%s" $ show monNumber :: String-- styleContext <- Gtk.widgetGetStyleContext window- styleContextAddClass styleContext "Taffybar"- widgetSetName window windowName-- windowSetTypeHint window WindowTypeHintDock- windowSetScreen window screen- setTaffybarSize wcfg window monNumber-- box <- hBoxNew False $ widgetSpacing wcfg- containerAdd window box-- mapM_- (\io -> do- wid <- io- widgetSetSizeRequest wid (-1) (barHeight wcfg)- boxPackStart box wid PackNatural 0)- (startWidgets wcfg)-- mapM_- (\io -> do- wid <- io- widgetSetSizeRequest wid (-1) (barHeight wcfg)- boxPackEnd box wid PackNatural 0)- (endWidgets wcfg)-- widgetShow window- widgetShow box- return window-- _ <- on screen screenMonitorsChanged refreshTaffyWindows-- startRefresher cfg $ postGUIAsync refreshTaffyWindows+ _ <- buildContext config - refreshTaffyWindows- -- Reset the size of the Taffybar window if the monitor setup has- -- changed, e.g., after a laptop user has attached an external- -- monitor. mainGUI return ()
+ src/System/Taffybar/Auth.hs view
@@ -0,0 +1,20 @@+{-# LANGUAGE OverloadedStrings #-}+module System.Taffybar.Auth where++import Control.Arrow+import Control.Monad.Trans+import Data.Maybe+import System.Taffybar.Util+import Text.Regex++fieldRegex :: Regex+fieldRegex = mkRegexWithOpts "^(.*?): *(.*?)$" True True++passGet :: MonadIO m => String -> m (Either String (String, [(String, String)]))+passGet credentialName =+ right (getPassComponents . lines) <$> runCommandFromPath ["pass", "show", credentialName]+ where getPassComponents passLines =+ let entries = map buildEntry $ catMaybes $ matchRegex fieldRegex <$> tail passLines+ buildEntry [fieldName, fieldValue] = (fieldName, fieldValue)+ buildEntry _ = ("", "")+ in (head passLines, entries)
− src/System/Taffybar/Battery.hs
@@ -1,208 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}--------------------------------------------------------------------------------- |--- 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,- textBatteryNew,- defaultBatteryConfig- ) where--import Control.Applicative-import qualified Control.Exception.Enclosed as E-import Data.Int (Int64)-import Data.IORef-import Graphics.UI.Gtk-import Safe (atMay)-import qualified System.IO as IO-import Text.Printf (printf)-import Text.StringTemplate--import Prelude--import System.Information.Battery-import System.Taffybar.Widgets.PollingBar-import System.Taffybar.Widgets.PollingLabel----- | Just the battery info that will be used for display (this makes combining several easier).-data BatteryWidgetInfo = BWI { seconds :: Maybe Int64- , percent :: Int- , status :: String- } deriving (Eq, Show)---- | Combination for 'BatteryWidgetInfo'.--- If one battery lacks time information, combination has no time information-combine :: [BatteryWidgetInfo] -> Maybe BatteryWidgetInfo-combine [] = Nothing-combine bs =- Just BWI { seconds = sum <$> sequence (seconds <$> bs)- , percent = sum (percent <$> bs) `div` length bs- , status = status $ head bs- }---- | Format a duration expressed as seconds to hours and minutes-formatDuration :: Maybe Int64 -> String-formatDuration Nothing = ""-formatDuration (Just secs) = let minutes = secs `div` 60- hours = minutes `div` 60- minutes' = minutes `mod` 60- in printf "%02d:%02d" hours minutes'--safeGetBatteryInfo :: IORef BatteryContext -> Int -> IO (Maybe BatteryInfo)-safeGetBatteryInfo mv i = do- ctxt <- readIORef mv- E.catchAny (getBatteryInfo ctxt) $ const reconnect- where- reconnect = do- IO.hPutStrLn IO.stderr "reconnecting"- ctxts <- batteryContextsNew- let mctxt = ctxts `atMay` i- case mctxt of- Nothing -> IO.hPutStrLn IO.stderr "Could not reconnect to UPower"- Just ctxt ->- writeIORef mv ctxt- return Nothing--getBatteryWidgetInfo :: IORef BatteryContext -> Int -> IO (Maybe BatteryWidgetInfo)-getBatteryWidgetInfo r i = do- minfo <- safeGetBatteryInfo r i- case minfo of- Nothing -> return Nothing- Just info -> do- let battPctNum :: Int- battPctNum = floor (batteryPercentage info)- battTime :: Maybe Int64- battTime = case batteryState info of- BatteryStateCharging -> Just $ batteryTimeToFull info- BatteryStateDischarging -> Just $ batteryTimeToEmpty info- _ -> Nothing- battStatus :: String- battStatus = case batteryState info of- BatteryStateCharging -> "Charging"- BatteryStateDischarging -> "Discharging"- _ -> "✔"- return . Just $ BWI { seconds = battTime- , percent = battPctNum- , status = battStatus- }----- | Given (maybe summarized) battery info and format: provides the string to display-formatBattInfo :: Maybe BatteryWidgetInfo -> String -> String-formatBattInfo Nothing _ = ""-formatBattInfo (Just info) fmt =- let tpl = newSTMP fmt- tpl' = setManyAttrib [ ("percentage", (show . percent) info)- , ("time", formatDuration (seconds info))- , ("status", status info)- ] tpl- in render tpl'---- | Provides textual information regarding multiple batteries-battSumm :: [IORef BatteryContext] -> String -> IO String-battSumm rs fmt = do- winfos <- traverse (uncurry getBatteryWidgetInfo) (rs `zip` [0..])- let ws :: [BatteryWidgetInfo]- ws = flatten winfos- flatten [] = []- flatten (Just a:as) = a:flatten as- flatten (Nothing:as) = flatten as- combined = combine ws- return $ formatBattInfo combined fmt----- | A simple textual battery widget that auto-updates once every--- polling period (specified in seconds). The displayed format is--- specified format string where $percentage$ is replaced with the--- percentage of battery remaining and $time$ is replaced with the--- time until the battery is fully charged/discharged.------ Multiple battery values are combined as follows:--- - for time remaining, the largest value is used.--- - for percentage, the mean is taken.-textBatteryNew :: [IORef BatteryContext]- -> String -- ^ Display format- -> Double -- ^ Poll period in seconds- -> IO Widget-textBatteryNew [] _ _ =- let lbl :: Maybe String- lbl = Just "No battery"- in toWidget <$> labelNew lbl-textBatteryNew rs fmt pollSeconds = do- l <- pollingLabelNew "" pollSeconds (battSumm rs fmt)- widgetShowAll l- return l----- | Returns the current battery percent as a double in the range [0,--- 1]-battPct :: IORef BatteryContext -> Int -> IO Double-battPct i r = do- minfo <- safeGetBatteryInfo i r- case minfo of- Nothing -> return 0- Just info -> return (batteryPercentage info / 100)---- | A default configuration for the graphical battery display. The--- bar will be red when power is critical (< 10%), green if it is full--- (> 90%), and grey otherwise.------ You can customize this with any of the options in 'BarConfig'-defaultBatteryConfig :: BarConfig-defaultBatteryConfig =- defaultBarConfig colorFunc- where- colorFunc pct- | pct < 0.1 = (1, 0, 0)- | pct < 0.9 = (0.5, 0.5, 0.5)- | otherwise = (0, 1, 0)----- | A fancy graphical battery widget that represents batteries--- as colored vertical bars (one per battery). There is also a--- textual percentage reppadout next to the bars, containing a summary of--- battery information.-batteryBarNew :: BarConfig -> Double -> IO Widget-batteryBarNew battCfg =- 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--- and status. An example: "$percentage$% ($time$) - $status$".-batteryBarNewWithFormat :: BarConfig -> String -> Double -> IO Widget-batteryBarNewWithFormat battCfg formatString pollSeconds = do- battCtxt <- batteryContextsNew- case battCtxt of- [] -> do- let lbl :: Maybe String- lbl = Just "No battery"- toWidget <$> labelNew lbl- cs -> do- b <- hBoxNew False 1- rs <- traverse newIORef cs- txt <- textBatteryNew rs formatString pollSeconds- let ris :: [(IORef BatteryContext, Int)]- ris = rs `zip` [0..]- 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- return (toWidget b)
− src/System/Taffybar/CPUMonitor.hs
@@ -1,40 +0,0 @@------------------------------------------------------------------------------------ |--- Module : System.Taffybar.CPUMonitor--- Copyright : (c) José A. Romero L.--- License : BSD3-style (see LICENSE)------ Maintainer : José A. Romero L. <escherdragon@gmail.com>--- Stability : unstable--- Portability : unportable------ Simple CPU monitor that uses a PollingGraph to visualize variations in the--- user and system CPU times in one selected core, or in all cores available.-------------------------------------------------------------------------------------module System.Taffybar.CPUMonitor where--import Data.IORef-import Graphics.UI.Gtk-import System.Information.CPU2 (getCPUInfo)-import System.Information.StreamInfo (getAccLoad)-import System.Taffybar.Widgets.PollingGraph---- | Creates a new CPU monitor. This is a PollingGraph fed by regular calls to--- getCPUInfo, associated to an IORef used to remember the values yielded by the--- last call to this function.-cpuMonitorNew :: GraphConfig -- ^ Configuration data for the Graph.- -> Double -- ^ Polling period (in seconds).- -> String -- ^ Name of the core to watch (e.g. \"cpu\", \"cpu0\").- -> IO Widget-cpuMonitorNew cfg interval cpu = do- info <- getCPUInfo cpu- sample <- newIORef info- pollingGraphNew cfg interval $ probe sample cpu--probe :: IORef [Int] -> String -> IO [Double]-probe sample cpuName = do- load <- getAccLoad sample $ getCPUInfo cpuName- case load of- l0:l1:l2:_ -> return [ l0 + l1, l2 ] -- user, system- _ -> return []
− src/System/Taffybar/CommandRunner.hs
@@ -1,48 +0,0 @@------------------------------------------------------------------------------------ |--- Module : System.Taffybar.CommandRunner--- Copyright : (c) Arseniy Seroka--- License : BSD3-style (see LICENSE)------ Maintainer : Arseniy Seroka <ars.seroka@gmail.com>--- Stability : unstable--- Portability : unportable------ Simple function which runs user defined command and--- returns it's output in PollingLabel widget--------------------------------------------------------------------------------------module System.Taffybar.CommandRunner ( commandRunnerNew ) where--import qualified Graphics.UI.Gtk as Gtk-import System.Taffybar.Pager (colorize)-import System.Taffybar.Widgets.PollingLabel--import Control.Monad-import System.Exit (ExitCode (..))-import qualified System.IO as IO-import qualified System.Process as P---- | Creates a new command runner widget. This is a 'PollingLabel' fed by--- regular calls to command given by argument. The results of calling this function--- are displayed as string.-commandRunnerNew :: Double -- ^ Polling period (in seconds).- -> String -- ^ Command to execute. Should be in $PATH or an absolute path- -> [String] -- ^ Command argument. May be @[]@- -> String -- ^ If command fails this will be displayed.- -> String -- ^ Output color- -> IO Gtk.Widget-commandRunnerNew interval cmd args defaultOutput color = do- label <- pollingLabelNew "" interval $ runCommand cmd args defaultOutput color- Gtk.widgetShowAll label- return $ Gtk.toWidget label--runCommand :: FilePath -> [String] -> String -> String -> IO String-runCommand cmd args defaultOutput color = do- (ecode, stdout, stderr) <- P.readProcessWithExitCode cmd args ""- unless (null stderr) $ do- IO.hPutStrLn IO.stderr stderr- return $ colorize color "" $ case ecode of- ExitSuccess -> stdout- ExitFailure _ -> defaultOutput
+ src/System/Taffybar/Compat/GtkLibs.hs view
@@ -0,0 +1,55 @@+-----------------------------------------------------------------------------+-- |+-- Module : System.Taffybar.Compat.GtkLibs+-- Copyright : (c) Ivan A. Malison+-- License : BSD3-style (see LICENSE)+--+-- Maintainer : Ivan A. Malison+-- Stability : unstable+-- Portability : unportable+-----------------------------------------------------------------------------+module System.Taffybar.Compat.GtkLibs where++import Control.Monad.IO.Class+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++fromGIPixBuf :: MonadIO m => PB.Pixbuf -> m Gtk.Pixbuf+fromGIPixBuf (PB.Pixbuf pbManagedPtr) = liftIO $+ wrapNewGObject Gtk.mkPixbuf (castPtr <$> disownManagedPtr pbManagedPtr)++fromGIWidget :: MonadIO m => GI.Gtk.Widget -> m Gtk.Widget+fromGIWidget (GI.Gtk.Widget wManagedPtr) = liftIO $+ wrapNewGObject Gtk.mkWidget (castPtr <$> disownManagedPtr wManagedPtr)++toGIWidget :: MonadIO m => Gtk.Widget -> m GI.Gtk.Widget+toGIWidget widget = liftIO $ do+ fPtr <- withForeignPtr (Gtk.unWidget widget) $+ flip GI.Gtk.newManagedPtr (return ()) . castPtr+ return $! GI.Gtk.Widget fPtr++toGIWindow :: MonadIO m => Gtk.Window -> m GI.Gtk.Window+toGIWindow window = liftIO $ 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 <- PB.pixbufNewFromData ptr ColorspaceRgb True 8+ width height rowStride (Just free)+ fromGIPixBuf giPb
src/System/Taffybar/Context.hs view
@@ -1,9 +1,9 @@+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MonoLocalBinds #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-}- ----------------------------------------------------------------------------- -- | -- Module : System.Taffybar.Context@@ -17,21 +17,44 @@ module System.Taffybar.Context where +import Control.Arrow ((&&&)) 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.Maybe import Control.Monad.Trans.Reader+import qualified DBus.Client as DBus import Data.Data+import Data.Int+import Data.List import qualified Data.Map as M+import Data.Tuple.Select+import Data.Tuple.Sequence import Data.Unique-import System.Information.SafeX11-import System.Information.X11DesktopInfo+import qualified GI.Gdk+import qualified GI.GdkX11 as GdkX11+import qualified GI.Gtk+import Graphics.UI.GIGtkStrut+import Graphics.UI.Gtk as Gtk+import System.Log.Logger+import System.Taffybar.Compat.GtkLibs+import System.Taffybar.Information.SafeX11+import System.Taffybar.Information.X11DesktopInfo+import System.Taffybar.TransparentWindow+import System.Taffybar.Widget.Util+import Text.Printf import Unsafe.Coerce -type Taffy m v = (MonadBase IO m) => ReaderT Context m v+logIO :: System.Log.Logger.Priority -> String -> IO ()+logIO = logM "System.Taffybar.Context"++logT :: MonadTrans t => System.Log.Logger.Priority -> String -> t IO ()+logT p m = lift $ logIO p m++type Taffy m v = MonadIO m => ReaderT Context m v+type TaffyIO v = ReaderT Context IO v type Listener = Event -> Taffy IO () type SubscriptionList = [(Unique, Listener)] data Value = forall t. Typeable t => Value t@@ -43,43 +66,226 @@ else Nothing +data BarConfig = BarConfig+ { strutConfig :: StrutConfig+ , widgetSpacing :: Int32+ , startWidgets :: [TaffyIO Gtk.Widget]+ , centerWidgets :: [TaffyIO Gtk.Widget]+ , endWidgets :: [TaffyIO Gtk.Widget]+ , barId :: Unique+ }++instance Eq BarConfig where+ a == b = barId a == barId b++type BarConfigGetter = TaffyIO [BarConfig]++data TaffybarConfig = TaffybarConfig+ { dbusClientParam :: Maybe DBus.Client+ , startupHook :: TaffyIO ()+ , getBarConfigsParam :: BarConfigGetter+ , errorMsg :: Maybe String+ }++defaultTaffybarConfig :: TaffybarConfig+defaultTaffybarConfig = TaffybarConfig+ { dbusClientParam = Nothing+ , startupHook = return ()+ , getBarConfigsParam = return []+ , errorMsg = Nothing+ }+ data Context = Context { x11ContextVar :: MV.MVar X11Context , listeners :: MV.MVar SubscriptionList , contextState :: MV.MVar (M.Map TypeRep Value)+ , existingWindows :: MV.MVar [(BarConfig, Gtk.Window)]+ , dbusClient :: DBus.Client+ , getBarConfigs :: BarConfigGetter } -buildEmptyContext :: IO Context-buildEmptyContext = do+buildContext :: TaffybarConfig -> IO Context+buildContext TaffybarConfig+ { dbusClientParam = maybeDBus+ , getBarConfigsParam = barConfigGetter+ , startupHook = startup+ } = do+ logIO DEBUG "Building context"+ dbusC <- maybe DBus.connectSession return maybeDBus+ _ <- DBus.requestName dbusC "org.taffybar.Bar"+ [DBus.nameAllowReplacement, DBus.nameReplaceExisting] listenersVar <- MV.newMVar [] state <- MV.newMVar M.empty- ctx <- getDefaultCtx- x11Context <- MV.newMVar ctx+ x11Context <- getDefaultCtx >>= MV.newMVar+ windowsVar <- MV.newMVar [] let context = Context { x11ContextVar = x11Context , listeners = listenersVar , contextState = state+ , dbusClient = dbusC+ , getBarConfigs = barConfigGetter+ , existingWindows = windowsVar }- runReaderT startX11EventHandler context+ _ <- runMaybeT $ MaybeT GI.Gdk.displayGetDefault >>=+ (lift . GI.Gdk.displayGetDefaultScreen) >>=+ (lift . flip GI.Gdk.afterScreenMonitorsChanged+ -- XXX: We have to do a force refresh here because there is no+ -- way to reliably move windows, since the window manager can do+ -- whatever it pleases.+ (runReaderT forceRefreshTaffyWindows context))+ flip runReaderT context $ do+ logT DEBUG "Starting X11 Handler"+ startX11EventHandler+ logT DEBUG "Running startup hook"+ startup+ logT DEBUG "Queing build windows command"+ refreshTaffyWindows+ logIO DEBUG "Context build finished" return context +buildEmptyContext :: IO Context+buildEmptyContext = buildContext defaultTaffybarConfig++instance GdkX11.IsX11Window GI.Gdk.Window++buildBarWindow :: Context -> BarConfig -> IO Gtk.Window+buildBarWindow context barConfig = do+ logIO DEBUG $+ printf "Building bar window with StrutConfig: %s" $+ show $ strutConfig barConfig++ window <- Gtk.windowNew+ box <- Gtk.hBoxNew False $ fromIntegral $ widgetSpacing barConfig+ _ <- widgetSetClass box "TaffyBox"+ centerBox <- Gtk.hBoxNew False $ fromIntegral $ widgetSpacing barConfig+ Gtk.boxSetCenterWidget box centerBox++ -- XXX: This conversion could leak memory+ giWindow <- toGIWindow window+ setupStrutWindow (strutConfig barConfig) giWindow+ Gtk.containerAdd window box++ _ <- widgetSetClass window "Taffybar"++ let addWidgetWith widgetAdd buildWidget =+ do+ widget <- runReaderT buildWidget context+ -- XXX: This is a pretty bad way to do this+ let height =+ case strutHeight $ strutConfig barConfig of+ ExactSize size -> fromIntegral size+ _ -> 40+ Gtk.widgetSetSizeRequest widget (-1) height+ widgetAdd widget+ addToStart widget = Gtk.boxPackStart box widget Gtk.PackNatural 0+ addToEnd widget = Gtk.boxPackEnd box widget Gtk.PackNatural 0+ addToCenter widget = Gtk.boxPackStart centerBox widget Gtk.PackNatural 0++ logIO DEBUG "Building start widgets"+ mapM_ (addWidgetWith addToStart) (startWidgets barConfig)+ logIO DEBUG "Building center widgets"+ mapM_ (addWidgetWith addToCenter) (centerWidgets barConfig)+ logIO DEBUG "Building end widgets"+ mapM_ (addWidgetWith addToEnd) (endWidgets barConfig)++ makeWindowTransparent giWindow++ logIO DEBUG "Showing window"+ widgetShow window+ widgetShow box+ widgetShow centerBox++ runX11Context context () $ void $ runMaybeT $ do+ gdkWindow <- MaybeT $ GI.Gtk.widgetGetWindow giWindow+ xid <- GdkX11.x11WindowGetXid gdkWindow+ lift $ doLowerWindow (fromIntegral xid)++ return window++refreshTaffyWindows :: TaffyIO ()+refreshTaffyWindows = liftReader Gtk.postGUIAsync $ do+ logT DEBUG "Refreshing windows"+ ctx <- ask+ windowsVar <- asks existingWindows++ let rebuildWindows currentWindows = flip runReaderT ctx $+ do+ barConfigs <- join $ asks getBarConfigs++ let currentConfigs = map sel1 currentWindows+ (_, newConfs) = partition (`elem` currentConfigs) barConfigs+ (remainingWindows, removedWindows) =+ partition ((`elem` barConfigs) . sel1) currentWindows+ setPropertiesFromPair (barConf, window) =+ toGIWindow window >>=+ setupStrutWindow (strutConfig barConf)++ newWindowPairs <- lift $ do+ logIO DEBUG $ printf "removedWindows: %s" $+ show $ map (strutConfig . sel1) removedWindows+ logIO DEBUG $ printf "remainingWindows: %s" $+ show $ map (strutConfig . sel1) remainingWindows+ logIO DEBUG $ printf "newWindows: %s" $+ show $ map strutConfig newConfs+ logIO DEBUG $ printf "barConfigs: %s" $+ show $ map strutConfig barConfigs++ logIO DEBUG "Removing windows"+ mapM_ (Gtk.widgetDestroy . sel2) removedWindows++ -- TODO: This should actually use the config that is provided from+ -- getBarConfigs so that the strut properties of the window can be+ -- altered.+ logIO DEBUG "Updating strut properties for existing windows"+ mapM_ setPropertiesFromPair remainingWindows++ logIO DEBUG "Constructing new windows"+ mapM (sequenceT . ((return :: a -> IO a) &&& buildBarWindow ctx)) newConfs++ return $ newWindowPairs ++ remainingWindows++ lift $ MV.modifyMVar_ windowsVar rebuildWindows+ logT DEBUG "Finished refreshing windows"+ return ()++forceRefreshTaffyWindows :: TaffyIO ()+forceRefreshTaffyWindows =+ asks existingWindows >>= lift . flip MV.modifyMVar_ deleteWindows >>+ refreshTaffyWindows+ where deleteWindows windows =+ do+ mapM_ (Gtk.widgetDestroy . sel2) windows+ return []+ 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 :: X11Property a -> TaffyIO a runX11 action = asksContextVar x11ContextVar >>= lift . runReaderT action +runX11Def :: a -> X11Property a -> TaffyIO a+runX11Def def prop = runX11 $ postX11RequestSyncProp prop def++runX11Context :: MonadIO m => Context -> a -> X11Property a -> m a+runX11Context context def prop =+ liftIO $ runReaderT (runX11Def def prop) context+ 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 ()+getStateDefault :: Typeable t => Taffy IO t -> Taffy IO t+getStateDefault defaultGetter =+ getState >>= maybe (defaultGetter >>= putState) return++putState :: Typeable t => t -> Taffy IO t putState v = do contextVar <- asks contextState lift $ MV.modifyMVar_ contextVar $ return . M.insert (typeOf v) (Value v)+ return v liftReader :: Monad m => (m1 a -> m b) -> ReaderT r m1 a -> ReaderT r m b
+ src/System/Taffybar/DBus.hs view
@@ -0,0 +1,27 @@+module System.Taffybar.DBus+ ( module System.Taffybar.DBus.Toggle+ , appendHook+ , startTaffyLogServer+ , withLogServer+ , withToggleServer+ ) where++import Control.Monad.Trans+import Control.Monad.Trans.Reader+import System.Log.DBus.Server+import System.Taffybar.Context+import System.Taffybar.DBus.Toggle++appendHook :: TaffyIO () -> TaffybarConfig -> TaffybarConfig+appendHook hook config = config+ { startupHook = startupHook config >> hook }++startTaffyLogServer :: TaffyIO ()+startTaffyLogServer =+ asks dbusClient >>= lift . startLogServer++withLogServer :: TaffybarConfig -> TaffybarConfig+withLogServer = appendHook startTaffyLogServer++withToggleServer :: TaffybarConfig -> TaffybarConfig+withToggleServer = handleDBusToggles
+ src/System/Taffybar/DBus/Toggle.hs view
@@ -0,0 +1,167 @@+{-# LANGUAGE OverloadedStrings #-}+-----------------------------------------------------------------------------+-- |+-- Module : System.Taffybar.DBus.Toggle+-- Copyright : (c) Ivan A. Malison+-- License : BSD3-style (see LICENSE)+--+-- Maintainer : Ivan A. Malison+-- Stability : unstable+-- Portability : unportable+--+-- This module provides a dbus interface that allows users to toggle the display+-- of taffybar on each monitor while it is running.+-----------------------------------------------------------------------------++module System.Taffybar.DBus.Toggle+ ( handleDBusToggles+ ) where++import Control.Applicative+import qualified Control.Concurrent.MVar as MV+import Control.Monad+import Control.Monad.Trans+import Control.Monad.Trans.Maybe+import Control.Monad.Trans.Reader+import DBus+import DBus.Client+import Data.Int+import qualified Data.Map as M+import qualified GI.Gdk as Gdk+import Data.Maybe+import Graphics.UI.GIGtkStrut+import Paths_taffybar ( getDataDir )+import Prelude+import System.Directory+import System.FilePath.Posix+import System.Log.Logger+import System.Taffybar.Context hiding (logIO, logT)+import Text.Printf+import Text.Read ( readMaybe )++-- $usage+--+-- To use this module, import it in your taffybar.hs and wrap your config with+-- the 'handleDBusToggles' function:+--+-- > main = dyreTaffybar $ handleDBusToggles myConfig+--+-- To toggle taffybar on the monitor that is currently active, issue the+-- following command:+--+-- > dbus-send --print-reply=literal --dest=taffybar.toggle /taffybar/toggle taffybar.toggle.toggleCurrent++logIO :: System.Log.Logger.Priority -> String -> IO ()+logIO = logM "System.Taffybar.DBus.Toggle"++logT :: MonadTrans t => System.Log.Logger.Priority -> String -> t IO ()+logT p m = lift $ logIO p m++getActiveMonitorNumber :: MaybeT IO Int+getActiveMonitorNumber = do+ display <- MaybeT Gdk.displayGetDefault+ seat <- lift $ Gdk.displayGetDefaultSeat display+ device <- MaybeT $ Gdk.seatGetPointer seat+ lift $ do+ (_, x, y) <- Gdk.deviceGetPosition device+ Gdk.displayGetMonitorAtPoint display x y >>= getMonitorNumber++getMonitorNumber :: Gdk.Monitor -> IO Int+getMonitorNumber monitor = do+ display <- Gdk.monitorGetDisplay monitor+ monitorCount <- Gdk.displayGetNMonitors display+ monitors <- mapM (Gdk.displayGetMonitor display) [0..(monitorCount-1)]+ monitorGeometry <- Gdk.getMonitorGeometry monitor+ let equalsMonitor (Just other, _) =+ do+ otherGeometry <- Gdk.getMonitorGeometry other+ case (otherGeometry, monitorGeometry) of+ (Nothing, Nothing) -> return True+ (Just g1, Just g2) -> Gdk.rectangleEqual g1 g2+ _ -> return False+ equalsMonitor _ = return False+ snd . fromMaybe (Nothing, 0) . listToMaybe <$> filterM equalsMonitor (zip monitors [0..])++taffybarTogglePath :: ObjectPath+taffybarTogglePath = "/taffybar/toggle"++taffybarToggleInterface :: InterfaceName+taffybarToggleInterface = "taffybar.toggle"++toggleStateFile :: IO FilePath+toggleStateFile = (</> "toggleState.hs") <$> getDataDir++newtype TogglesMVar = TogglesMVar (MV.MVar (M.Map Int Bool))++getTogglesVar :: TaffyIO TogglesMVar+getTogglesVar = getStateDefault $ lift (TogglesMVar <$> MV.newMVar M.empty)++toggleBarConfigGetter :: BarConfigGetter -> BarConfigGetter+toggleBarConfigGetter getConfigs = do+ barConfigs <- getConfigs+ TogglesMVar enabledVar <- getTogglesVar+ numToEnabled <- lift $ MV.readMVar enabledVar+ let isEnabled monNumber = fromMaybe True $ M.lookup monNumber numToEnabled+ isConfigEnabled = isEnabled . fromIntegral . fromMaybe 0 . strutMonitor . strutConfig+ return $ filter isConfigEnabled barConfigs++exportTogglesInterface :: TaffyIO ()+exportTogglesInterface = do+ TogglesMVar enabledVar <- getTogglesVar+ ctx <- ask+ 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+ return result+ refreshTaffyWindows+ toggleTaffy = do+ num <- runMaybeT getActiveMonitorNumber+ toggleTaffyOnMon not $ fromMaybe 0 num+ takeInt :: (Int -> a) -> (Int32 -> a)+ takeInt = (. fromIntegral)+ client <- asks dbusClient+ let interface =+ defaultInterface+ { interfaceName = taffybarToggleInterface+ , interfaceMethods =+ [ autoMethod "toggleCurrent" toggleTaffy+ , autoMethod "toggleOnMonitor" $ takeInt $ toggleTaffyOnMon not+ , autoMethod "hideOnMonitor" $+ takeInt $ toggleTaffyOnMon (const False)+ , autoMethod "showOnMonitor" $+ takeInt $ toggleTaffyOnMon (const True)+ , autoMethod "refresh" $ runReaderT refreshTaffyWindows ctx+ ]+ }+ lift $ do+ _ <- requestName client "taffybar.toggle"+ [nameAllowReplacement, nameReplaceExisting]+ export client taffybarTogglePath interface++dbusTogglesStartupHook :: TaffyIO ()+dbusTogglesStartupHook = do+ TogglesMVar enabledVar <- getTogglesVar+ logT DEBUG "Loading toggle state"+ lift $ do+ stateFilepath <- toggleStateFile+ filepathExists <- doesFileExist stateFilepath+ mStartingMap <-+ if filepathExists+ then+ readMaybe <$> readFile stateFilepath+ else+ return Nothing+ MV.modifyMVar_ enabledVar $ const $ return $ fromMaybe M.empty mStartingMap+ logT DEBUG "Exporting toggles interface"+ exportTogglesInterface++handleDBusToggles :: TaffybarConfig -> TaffybarConfig+handleDBusToggles config =+ config { getBarConfigsParam =+ toggleBarConfigGetter $ getBarConfigsParam config+ , startupHook = startupHook config >> dbusTogglesStartupHook+ }
− src/System/Taffybar/DiskIOMonitor.hs
@@ -1,37 +0,0 @@------------------------------------------------------------------------------------ |--- Module : System.Taffybar.DiskIOMonitor--- Copyright : (c) José A. Romero L.--- License : BSD3-style (see LICENSE)------ Maintainer : José A. Romero L. <escherdragon@gmail.com>--- Stability : unstable--- Portability : unportable------ Simple Disk IO monitor that uses a PollingGraph to visualize the speed of--- read/write operations in one selected disk or partition.--------------------------------------------------------------------------------------module System.Taffybar.DiskIOMonitor ( dioMonitorNew ) where--import qualified Graphics.UI.Gtk as Gtk-import System.Information.DiskIO ( getDiskTransfer )-import System.Taffybar.Widgets.PollingGraph ( GraphConfig, pollingGraphNew )---- | Creates a new disk IO monitor widget. This is a 'PollingGraph' fed by--- regular calls to 'getDiskTransfer'. The results of calling this function--- are normalized to the maximum value of the obtained probe (either read or--- write transfer).-dioMonitorNew :: GraphConfig -- ^ Configuration data for the Graph.- -> Double -- ^ Polling period (in seconds).- -> String -- ^ Name of the disk or partition to watch (e.g. \"sda\", \"sdb1\").- -> IO Gtk.Widget-dioMonitorNew cfg pollSeconds =- pollingGraphNew cfg pollSeconds . probeDisk--probeDisk :: String -> IO [Double]-probeDisk disk = do- transfer <- getDiskTransfer disk- let top = foldr max 1.0 transfer- return $ map (/top) transfer
− src/System/Taffybar/FSMonitor.hs
@@ -1,38 +0,0 @@--------------------------------------------------------------------------------- |--- Module : System.Taffybar.FSMonitor--- Copyright : (c) José A. Romero L.--- License : BSD3-style (see LICENSE)------ Maintainer : José A. Romero L. <escherdragon@gmail.com>--- Stability : unstable--- Portability : unportable------ Simple text widget that monitors the current usage of selected disk--- partitions by regularly parsing the output of the df command in Linux--- systems.-----------------------------------------------------------------------------------module System.Taffybar.FSMonitor ( fsMonitorNew ) where--import qualified Graphics.UI.Gtk as Gtk-import System.Process ( readProcess )-import System.Taffybar.Widgets.PollingLabel ( pollingLabelNew )---- | Creates a new filesystem monitor widget. It contains one 'PollingLabel'--- that displays the data returned by the df command. The usage level of all--- requested partitions is extracted in one single operation.-fsMonitorNew :: Double -- ^ Polling interval (in seconds, e.g. 500)- -> [String] -- ^ Names of the partitions to monitor (e.g. [\"\/\", \"\/home\"])- -> IO Gtk.Widget-fsMonitorNew interval fsList = do- label <- pollingLabelNew "" interval $ showFSInfo fsList- Gtk.widgetShowAll label- return $ Gtk.toWidget label--showFSInfo :: [String] -> IO String-showFSInfo fsList = do- fsOut <- readProcess "df" (["-kP"] ++ fsList) ""- let fss = map (take 2 . reverse . words) $ drop 1 $ lines fsOut- return $ unwords $ map ((\s -> "[" ++ s ++ "]") . unwords) fss
− src/System/Taffybar/FreedesktopNotifications.hs
@@ -1,280 +0,0 @@-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE ScopedTypeVariables #-}--- | This widget listens on DBus for freedesktop notifications--- (http://developer.gnome.org/notification-spec/). Currently it is--- somewhat ugly, but the format is somewhat configurable. A visual--- overhaul of the widget is coming.------ The widget only displays one notification at a time and--- notifications are cancellable.---- The notificationDaemon thread handles new notifications--- and cancellation requests, adding or removing the notification--- to or from the queue. It additionally starts a timeout thread--- for each notification added to queue.------ The display thread blocks idling until it is awakened to refresh the GUI------ A timeout thread is associated with a notification id.--- It sleeps until the specific timeout and then removes every notification--- with that id from the queue--module System.Taffybar.FreedesktopNotifications (- -- * Types- Notification(..),- NotificationConfig(..),- -- * Constructor- notifyAreaNew,- defaultNotificationConfig- ) where--import Control.Concurrent-import Control.Concurrent.STM-import Control.Monad ( forever, void )-import Control.Monad.Trans ( liftIO )-import Data.Int ( Int32 )-import Data.Foldable-import Data.Map ( Map )-import Data.Monoid-import qualified Data.Sequence as S-import Data.Sequence ( Seq, (|>), viewl, ViewL(..) )-import Data.Text ( Text )-import qualified Data.Text as T-import Data.Word ( Word32 )-import DBus-import DBus.Client-import Graphics.UI.Gtk hiding ( Variant )---- | A simple structure representing a Freedesktop notification-data Notification = Notification { noteAppName :: Text- , noteReplaceId :: Word32- , noteSummary :: Text- , noteBody :: Text- , noteExpireTimeout :: Maybe Int32- , noteId :: Word32- }- deriving (Show, Eq)--data NotifyState = NotifyState { noteWidget :: Label- , noteContainer :: Widget- , 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- }--initialNoteState :: Widget -> Label -> NotificationConfig -> IO NotifyState-initialNoteState wrapper l cfg = do- m <- newTVarIO 1- q <- newTVarIO S.empty- ch <- newChan- return NotifyState { noteQueue = q- , noteIdSource = m- , noteWidget = l- , noteContainer = wrapper- , noteConfig = cfg- , noteChan = ch- }---- | Removes every notification with id 'nId' from the queue-notePurge :: NotifyState -> Word32 -> IO ()-notePurge s nId = atomically . modifyTVar' (noteQueue s) $- S.filter ((nId /=) . noteId)---- | Removes the first (oldest) notification from the queue-noteNext :: NotifyState -> IO ()-noteNext s = atomically $ modifyTVar' (noteQueue s) aux- where- aux queue = case viewl queue of- EmptyL -> S.empty- _ :< ns -> ns---- | Generates a fresh notification id-noteFreshId :: NotifyState -> IO Word32-noteFreshId (NotifyState { noteIdSource }) = atomically $ do- nId <- readTVar noteIdSource- writeTVar noteIdSource (succ nId)- return nId------------------------------------------------------------------------------------- | Handles a new notification-notify :: NotifyState- -> Text -- ^ Application name- -> Word32 -- ^ Replaces id- -> Text -- ^ App icon- -> Text -- ^ Summary- -> Text -- ^ Body- -> [Text] -- ^ Actions- -> Map Text Variant -- ^ Hints- -> Int32 -- ^ Expires timeout (milliseconds)- -> IO Word32-notify s appName replaceId _ summary body _ _ timeout = do- realId <- if replaceId == 0 then noteFreshId s else return replaceId- let escapeText = T.pack . escapeMarkup . T.unpack- configTimeout = notificationMaxTimeout (noteConfig s)- realTimeout = if timeout <= 0 -- Gracefully handle out of spec negative values- then configTimeout- else case configTimeout of- Nothing -> Just timeout- Just maxTimeout -> Just (min maxTimeout timeout)- n = Notification { noteAppName = appName- , noteReplaceId = replaceId- , noteSummary = escapeText summary- , noteBody = escapeText body- , noteExpireTimeout = realTimeout- , noteId = realId- }- -- Either add the new note to the queue or replace an existing note if their ids match- atomically $ do- queue <- readTVar $ noteQueue s- writeTVar (noteQueue s) $ case S.findIndexL (\n_ -> noteId n == noteId n_) queue of- Nothing -> queue |> n- Just index -> S.update index n queue- startTimeoutThread s n- wakeupDisplayThread s- return realId---- | Handles user cancellation of a notification-closeNotification :: NotifyState -> Word32 -> IO ()-closeNotification s nId = do- notePurge s nId- wakeupDisplayThread s--notificationDaemon :: (AutoMethod f1, AutoMethod f2)- => f1 -> f2 -> IO ()-notificationDaemon onNote onCloseNote = do- client <- connectSession- _ <- requestName client "org.freedesktop.Notifications" [nameAllowReplacement, nameReplaceExisting]- export client "/org/freedesktop/Notifications" interface- where- getServerInformation :: IO (Text, Text, Text, Text)- getServerInformation = return ("haskell-notification-daemon",- "nochair.net",- "0.0.1",- "1.1")- getCapabilities :: IO [Text]- getCapabilities = return ["body", "body-markup"]- interface = defaultInterface- { interfaceName = "org.freedesktop.Notifications"- , interfaceMethods =- [ autoMethod "GetServerInformation" getServerInformation- , autoMethod "GetCapabilities" getCapabilities- , autoMethod "CloseNotification" onCloseNote- , autoMethod "Notify" onNote- ]- }-----------------------------------------------------------------------------------wakeupDisplayThread :: NotifyState -> IO ()-wakeupDisplayThread s = writeChan (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)- where- formatMessage (NotificationConfig {..}) ns =- take notificationMaxLength $ notificationFormatter ns-----------------------------------------------------------------------------------startTimeoutThread :: NotifyState -> Notification -> IO ()-startTimeoutThread s (Notification {..}) = case noteExpireTimeout of- Nothing -> return ()- Just timeout -> void $ forkIO $ do- threadDelay (fromIntegral timeout * 10^(6 :: Int))- notePurge s noteId- wakeupDisplayThread s-----------------------------------------------------------------------------------data NotificationConfig =- NotificationConfig { notificationMaxTimeout :: Maybe Int32 -- ^ Maximum time that a notification will be displayed (in seconds). Default: None- , notificationMaxLength :: Int -- ^ Maximum length displayed, in characters. Default: 100- , notificationFormatter :: [Notification] -> String -- ^ Function used to format notifications, takes the notifications from first to last- }--defaultFormatter :: [Notification] -> String-defaultFormatter ns =- let count = length ns- n = head ns- prefix = if count == 1- then ""- else "(" <> show count <> ") "- msg = T.unpack $ if T.null (noteBody n)- then noteSummary n- else noteSummary n <> ": " <> noteBody n- in "<span fgcolor='yellow'>" <> prefix <> "</span>" <> msg---- | The default formatter is one of--- * Summary : Body--- * Summary--- * (N) Summary : Body--- * (N) Summary--- depending on the presence of a notification body, and where N is the number of queued notifications.-defaultNotificationConfig :: NotificationConfig-defaultNotificationConfig =- NotificationConfig { notificationMaxTimeout = Nothing- , notificationMaxLength = 100- , notificationFormatter = defaultFormatter- }---- | Create a new notification area with the given configuration.-notifyAreaNew :: NotificationConfig -> IO Widget-notifyAreaNew cfg = do- frame <- frameNew- box <- hBoxNew False 3- textArea <- labelNew (Nothing :: Maybe String)- button <- eventBoxNew- sep <- vSeparatorNew-- bLabel <- labelNew (Nothing :: Maybe String)- widgetSetName bLabel ("NotificationCloseButton" :: String)- labelSetMarkup bLabel ("×" :: String)-- labelSetMaxWidthChars textArea (notificationMaxLength cfg)- labelSetEllipsize textArea EllipsizeEnd-- containerAdd button bLabel- boxPackStart box textArea PackGrow 0- boxPackStart box sep PackNatural 0- boxPackStart box button PackNatural 0-- containerAdd frame box-- widgetHide frame-- s <- initialNoteState (toWidget frame) textArea cfg- _ <- on button buttonReleaseEvent (userCancel s)-- realizableWrapper <- hBoxNew False 0- boxPackStart realizableWrapper frame PackNatural 0- widgetShow realizableWrapper-- -- We can't start the dbus listener thread until we are in the GTK- -- main loop, otherwise things are prone to lock up and block- -- infinitely on an mvar. Bad stuff - only start the dbus thread- -- after the fake invisible wrapper widget is realized.- void $ on realizableWrapper realize $ do- void $ forkIO (displayThread s)- notificationDaemon (notify s) (closeNotification s)-- -- Don't show the widget by default - it will appear when needed- return (toWidget realizableWrapper)- where- -- | Close the current note and pull up the next, if any- userCancel s = liftIO $ do- noteNext s- wakeupDisplayThread s- return True
− src/System/Taffybar/GtkLibCompat.hs
@@ -1,45 +0,0 @@--------------------------------------------------------------------------------- |--- 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
+ src/System/Taffybar/Hooks.hs view
@@ -0,0 +1,21 @@+module System.Taffybar.Hooks+ ( module System.Taffybar.DBus+ , module System.Taffybar.Hooks+ ) where++import Control.Concurrent+import Control.Monad.Trans+import System.Taffybar.Context+import System.Taffybar.DBus+import System.Taffybar.Information.Network++newtype NetworkInfoChan = NetworkInfoChan (Chan [(String, (Rational, Rational))])++buildInfoChan :: Double -> IO NetworkInfoChan+buildInfoChan interval = do+ chan <- newChan+ _ <- forkIO $ monitorNetworkInterfaces interval $ writeChan chan+ return $ NetworkInfoChan chan++getNetworkChan :: TaffyIO NetworkInfoChan+getNetworkChan = getStateDefault $ lift $ buildInfoChan 2.0
− src/System/Taffybar/Hooks/PagerHints.hs
@@ -1,115 +0,0 @@--------------------------------------------------------------------------------- |--- Module : System.Taffybar.Hooks.PagerHints--- Copyright : (c) José A. Romero L.--- License : BSD3-style (see LICENSE)------ Maintainer : José A. Romero L. <escherdragon@gmail.com>--- Stability : unstable--- Portability : unportable------ Complements the "XMonad.Hooks.EwmhDesktops" with two additional hints--- not contemplated by the EWMH standard:------ [@_XMONAD_CURRENT_LAYOUT@] Contains a UTF-8 string with the name of the--- windows layout currently used in the active workspace.------ [@_XMONAD_VISIBLE_WORKSPACES@] Contains a list of UTF-8 strings with the--- names of all the workspaces that are currently showed in a secondary--- display, or an empty list if in the current installation there's only--- one monitor.------ The first hint can be set directly on the root window of the default--- display, or indirectly via X11 events with an atom of the same--- name. This allows both to track any changes that occur in the layout of--- the current workspace, as well as to have it changed automatically by--- just sending a custom event to the hook.------ The second one should be considered read-only, and is set every time--- XMonad calls its log hooks.-----------------------------------------------------------------------------------module System.Taffybar.Hooks.PagerHints (- -- * Usage- -- $usage- pagerHints-) where--import Codec.Binary.UTF8.String (encode)-import Control.Monad-import Data.Monoid-import Foreign.C.Types (CInt)-import XMonad-import qualified XMonad.StackSet as W---- $usage------ You can use this module with the following in your @xmonad.hs@ file:------ > import System.Taffybar.Hooks.PagerHints (pagerHints)--- >--- > main = xmonad $ ewmh $ pagerHints $ defaultConfig--- > ...---- | The \"Current Layout\" custom hint.-xLayoutProp :: X Atom-xLayoutProp = getAtom "_XMONAD_CURRENT_LAYOUT"---- | The \"Visible Workspaces\" custom hint.-xVisibleProp :: X Atom-xVisibleProp = getAtom "_XMONAD_VISIBLE_WORKSPACES"---- | Add support for the \"Current Layout\" and \"Visible Workspaces\" custom--- hints to the given config.-pagerHints :: XConfig a -> XConfig a-pagerHints c = c { handleEventHook = handleEventHook c +++ pagerHintsEventHook- , logHook = logHook c +++ pagerHintsLogHook }- where x +++ y = x `mappend` y---- | Update the current values of both custom hints.-pagerHintsLogHook :: X ()-pagerHintsLogHook = do- withWindowSet- (setCurrentLayout . description . W.layout . W.workspace . W.current)- withWindowSet- (setVisibleWorkspaces . map (W.tag . W.workspace) . W.visible)---- | Set the value of the \"Current Layout\" custom hint to the one given.-setCurrentLayout :: String -> X ()-setCurrentLayout l = withDisplay $ \dpy -> do- r <- asks theRoot- a <- xLayoutProp- c <- getAtom "UTF8_STRING"- let l' = map fromIntegral (encode l)- io $ changeProperty8 dpy r a c propModeReplace l'---- | Set the value of the \"Visible Workspaces\" hint to the one given.-setVisibleWorkspaces :: [String] -> X ()-setVisibleWorkspaces vis = withDisplay $ \dpy -> do- r <- asks theRoot- a <- xVisibleProp- c <- getAtom "UTF8_STRING"- let vis' = map fromIntegral $ concatMap ((++[0]) . encode) vis- io $ changeProperty8 dpy r a c propModeReplace vis'---- | Handle all \"Current Layout\" events received from pager widgets, and--- set the current layout accordingly.-pagerHintsEventHook :: Event -> X All-pagerHintsEventHook ClientMessageEvent {- ev_message_type = mt,- ev_data = d- } = withWindowSet $ \_ -> do- a <- xLayoutProp- when (mt == a) $ sendLayoutMessage d- return (All True)-pagerHintsEventHook _ = return (All True)---- | Request a change in the current layout by sending an internal message--- to XMonad.-sendLayoutMessage :: [CInt] -> X ()-sendLayoutMessage evData = case evData of- [] -> return ()- x:_ -> if x < 0- then sendMessage FirstLayout- else sendMessage NextLayout
src/System/Taffybar/IconImages.hs view
@@ -15,22 +15,19 @@ pixBufFromEWMHIcon, pixelsARGBToBytesABGR, pixBufFromColor,- pixBufFromFile,- selectEWMHIcon+ pixBufFromFile ) where -- TODO: rename module to IconPixbuf import Data.Bits-import qualified Data.List as L-import Data.Ord ( comparing ) import Data.Word 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+import System.Taffybar.Information.EWMHDesktopInfo+import System.Taffybar.Compat.GtkLibs type ColorRGBA = (Word8, Word8, Word8, Word8) @@ -59,7 +56,6 @@ pixBufFromEWMHIcon EWMHIcon {width = w, height = h, pixelsARGB = px} = do 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@@ -99,10 +95,3 @@ pixBufFromFile :: Int -> FilePath -> IO Gtk.Pixbuf pixBufFromFile imgSize file = Gtk.pixbufNewFromFileAtScale file imgSize imgSize False--selectEWMHIcon :: Int -> [EWMHIcon] -> EWMHIcon-selectEWMHIcon imgSize icons = head prefIcon- where sortedIcons = L.sortBy (comparing height) icons- smallestLargerIcon = take 1 $ dropWhile ((<= imgSize) . height) sortedIcons- largestIcon = take 1 $ reverse sortedIcons- prefIcon = smallestLargerIcon ++ largestIcon
+ src/System/Taffybar/Information/Battery.hs view
@@ -0,0 +1,198 @@+{-# LANGUAGE OverloadedStrings #-}+-- | This is a simple library to query the Linux UPower daemon (via DBus) for+-- battery information. Currently, it only retrieves information for the first+-- battery it finds.+module System.Taffybar.Information.Battery (+ -- * Types+ BatteryContext,+ BatteryInfo(..),+ BatteryState(..),+ BatteryTechnology(..),+ BatteryType(..),+ -- * Accessors+ batteryContextsNew,+ getBatteryInfo+ ) where++import Data.Map ( Map )+import qualified Data.Map as M+import Data.Maybe ( fromMaybe, maybeToList )+import Data.Word+import Data.Int+import DBus+import DBus.Client+import Data.List ( isInfixOf )+import Data.Text ( Text )+import qualified Data.Text as T+import Safe ( atMay )++-- | An opaque wrapper around some internal library state+data BatteryContext = BC Client ObjectPath++data BatteryType+ = BatteryTypeUnknown+ | BatteryTypeLinePower+ | BatteryTypeBatteryType+ | BatteryTypeUps+ | BatteryTypeMonitor+ | BatteryTypeMouse+ | BatteryTypeKeyboard+ | BatteryTypePda+ | BatteryTypePhone+ deriving (Show, Ord, Eq, Enum)++data BatteryState+ = BatteryStateUnknown+ | BatteryStateCharging+ | BatteryStateDischarging+ | BatteryStateEmpty+ | BatteryStateFullyCharged+ | BatteryStatePendingCharge+ | BatteryStatePendingDischarge+ deriving (Show, Ord, Eq, Enum)++data BatteryTechnology+ = BatteryTechnologyUnknown+ | BatteryTechnologyLithiumIon+ | BatteryTechnologyLithiumPolymer+ | BatteryTechnologyLithiumIronPhosphate+ | BatteryTechnologyLeadAcid+ | BatteryTechnologyNickelCadmium+ | BatteryTechnologyNickelMetalHydride+ deriving (Show, Ord, Eq, Enum)++-- | There are a few fields supported by UPower that aren't exposed+-- here.. could be easily.+data BatteryInfo = BatteryInfo+ { batteryNativePath :: Text+ , batteryVendor :: Text+ , batteryModel :: Text+ , batterySerial :: Text+ , batteryType :: BatteryType+ , batteryPowerSupply :: Bool+ , batteryHasHistory :: Bool+ , batteryHasStatistics :: Bool+ , batteryOnline :: Bool+ , batteryEnergy :: Double+ , batteryEnergyEmpty :: Double+ , batteryEnergyFull :: Double+ , batteryEnergyFullDesign :: Double+ , batteryEnergyRate :: Double+ , batteryVoltage :: Double+ , batteryTimeToEmpty :: Int64+ , batteryTimeToFull :: Int64+ , batteryPercentage :: Double+ , batteryIsPresent :: Bool+ , batteryState :: BatteryState+ , batteryIsRechargable :: Bool+ , batteryCapacity :: Double+ , batteryTechnology :: BatteryTechnology+ }+{-+ , batteryUpdateTime :: Time+ , batteryRecallNotice :: Bool+ , batteryRecallVendor :: Text+ , batteryRecallUr :: Text+-}++-- | determine if a power source is a battery. The simple heuristic is a+-- substring search on 'BAT'.+isBattery :: ObjectPath -> Bool+isBattery = isInfixOf "BAT" . formatObjectPath++-- | Find the power sources that are batteries (according to+-- 'isBattery')+batteries :: [ObjectPath] -> [ObjectPath]+batteries = filter isBattery++-- | The name of the power daemon bus+powerBusName :: BusName+powerBusName = "org.freedesktop.UPower"++-- | The base object path+powerBaseObjectPath :: ObjectPath+powerBaseObjectPath = "/org/freedesktop/UPower"++-- | A helper to read the variant contents of a dict with a default+-- value.+readDict :: (IsVariant a) => Map Text Variant -> Text -> a -> a+readDict dict key dflt = fromMaybe dflt $ do+ variant <- M.lookup key dict+ fromVariant variant++-- | Read the variant contents of a dict which is of an unknown integral type.+readDictIntegral :: Map Text Variant -> Text -> Int32 -> Int+readDictIntegral dict key dflt = fromMaybe (fromIntegral dflt) $ do+ v <- M.lookup key dict+ case variantType v of+ TypeWord8 -> return $ fromIntegral (f v :: Word8)+ TypeWord16 -> return $ fromIntegral (f v :: Word16)+ TypeWord32 -> return $ fromIntegral (f v :: Word32)+ TypeWord64 -> return $ fromIntegral (f v :: Word64)+ TypeInt16 -> return $ fromIntegral (f v :: Int16)+ TypeInt32 -> return $ fromIntegral (f v :: Int32)+ TypeInt64 -> return $ fromIntegral (f v :: Int64)+ _ -> Nothing+ where+ f :: (Num a, IsVariant a) => Variant -> a+ f = fromMaybe (fromIntegral dflt) . fromVariant++-- | Query the UPower daemon about information on a specific battery.+-- If some fields are not actually present, they may have bogus values+-- here. Don't bet anything critical on it.+getBatteryInfo :: BatteryContext -> IO (Maybe BatteryInfo)+getBatteryInfo (BC systemConn battPath)+ -- Grab all of the properties of the battery each call with one+ -- message.+ = do+ reply <-+ call_+ systemConn+ (methodCall battPath "org.freedesktop.DBus.Properties" "GetAll")+ { methodCallDestination = Just "org.freedesktop.UPower"+ , methodCallBody = [toVariant $ T.pack "org.freedesktop.UPower.Device"]+ }+ return $ do+ body <- methodReturnBody reply `atMay` 0+ dict <- fromVariant body+ return+ BatteryInfo+ { batteryNativePath = readDict dict "NativePath" ""+ , batteryVendor = readDict dict "Vendor" ""+ , batteryModel = readDict dict "Model" ""+ , batterySerial = readDict dict "Serial" ""+ , batteryType = toEnum $ fromIntegral $ readDictIntegral dict "Type" 0+ , batteryPowerSupply = readDict dict "PowerSupply" False+ , batteryHasHistory = readDict dict "HasHistory" False+ , batteryHasStatistics = readDict dict "HasStatistics" False+ , batteryOnline = readDict dict "Online" False+ , batteryEnergy = readDict dict "Energy" 0.0+ , batteryEnergyEmpty = readDict dict "EnergyEmpty" 0.0+ , batteryEnergyFull = readDict dict "EnergyFull" 0.0+ , batteryEnergyFullDesign = readDict dict "EnergyFullDesign" 0.0+ , batteryEnergyRate = readDict dict "EnergyRate" 0.0+ , batteryVoltage = readDict dict "Voltage" 0.0+ , batteryTimeToEmpty = readDict dict "TimeToEmpty" 0+ , batteryTimeToFull = readDict dict "TimeToFull" 0+ , batteryPercentage = readDict dict "Percentage" 0.0+ , batteryIsPresent = readDict dict "IsPresent" False+ , batteryState = toEnum $ readDictIntegral dict "State" 0+ , batteryIsRechargable = readDict dict "IsRechargable" True+ , batteryCapacity = readDict dict "Capacity" 0.0+ , batteryTechnology =+ toEnum $ fromIntegral $ readDictIntegral dict "Technology" 0+ }++-- | Construct a battery context for every battery in the system. This+-- could fail if the UPower daemon is not running. The contexts can be+-- used to get actual battery state with 'getBatteryInfo'.+batteryContextsNew :: IO [BatteryContext]+batteryContextsNew = do+ systemConn <- connectSystem+ let mc = methodCall powerBaseObjectPath "org.freedesktop.UPower" "EnumerateDevices"+ reply <- call_ systemConn mc { methodCallDestination = Just powerBusName }+ return $ do+ body <- take 1 $ methodReturnBody reply+ powerDevices <- maybeToList $ fromVariant body+ battPath <- batteries powerDevices+ return $ BC systemConn battPath
+ src/System/Taffybar/Information/CPU.hs view
@@ -0,0 +1,35 @@+module System.Taffybar.Information.CPU ( cpuLoad ) where++import Control.Concurrent ( threadDelay )+import System.IO ( IOMode(ReadMode), openFile, hGetLine, hClose )++procData :: IO [Double]+procData = do+ h <- openFile "/proc/stat" ReadMode+ firstLine <- hGetLine h+ length firstLine `seq` return ()+ hClose h+ return (procParser firstLine)++procParser :: String -> [Double]+procParser = map read . tail . words++truncVal :: Double -> Double+truncVal v+ | isNaN v || v < 0.0 = 0.0+ | otherwise = v++-- | Return a pair with (user time, system time, total time) (read+-- from /proc/stat). The function waits for 50 ms between samples.+cpuLoad :: IO (Double, Double, Double)+cpuLoad = do+ a <- procData+ threadDelay 50000+ b <- procData+ let dif = zipWith (-) b a+ tot = sum dif+ pct = map (/ tot) dif+ user = sum $ take 2 pct+ system = pct !! 2+ t = user + system+ return (truncVal user, truncVal system, truncVal t)
+ src/System/Taffybar/Information/CPU2.hs view
@@ -0,0 +1,64 @@+-----------------------------------------------------------------------------+-- |+-- Module : System.Taffybar.Information.CPU2+-- Copyright : (c) José A. Romero L.+-- License : BSD3-style (see LICENSE)+--+-- Maintainer : José A. Romero L. <escherdragon@gmail.com>+-- Stability : unstable+-- Portability : unportable+--+-- Provides information about used CPU times, obtained from parsing the+-- @\/proc\/stat@ file using some of the facilities included in the+-- "System.Taffybar.Information.StreamInfo" module.+-- And also provides information about the temperature of cores.+-- (Now supports only physical cpu).+--+-----------------------------------------------------------------------------++module System.Taffybar.Information.CPU2 ( getCPULoad, getCPUInfo, getCPUTemp ) where++import Data.Maybe ( mapMaybe )+import Safe ( atMay, readDef, tailSafe )+import System.Taffybar.Information.StreamInfo ( getLoad, getParsedInfo )++-- | Returns a two-element list containing relative system and user times+-- calculated using two almost simultaneous samples of the @\/proc\/stat@ file+-- for the given core (or all of them aggregated, if \"cpu\" is passed).+getCPULoad :: String -> IO [Double]+getCPULoad cpu = do+ load <- getLoad 0.05 $ getCPUInfo cpu+ case load of+ l0:l1:l2:_ -> return [ l0 + l1, l2 ]+ _ -> return []++-- | Returns a list containing temperatures of user given cpu cores.+-- Use ["cpu1", "cpu2".."cpuN"] to get temperature of exact cores.+-- Use ["cpu0"] to get common temperature.+getCPUTemp :: [String] -> IO [Int]+getCPUTemp cpus = do+ let cpus' = map (\s -> [last s]) cpus+ concat <$>+ mapM+ (\cpu ->+ getParsedInfo+ ("/sys/bus/platform/devices/coretemp.0/temp" +++ show ((read cpu :: Int) + 1) ++ "_input")+ (\s -> [("temp", [(read s :: Int) `div` 1000])])+ "temp")+ cpus'+ --TODO and suppoprt for more than 1 physical cpu.++-- | Returns a list of 5 to 7 elements containing all the values available for+-- the given core (or all of them aggregated, if "cpu" is passed).+getCPUInfo :: String -> IO [Int]+getCPUInfo = getParsedInfo "/proc/stat" parse++parse :: String -> [(String, [Int])]+parse = mapMaybe (tuplize . words) . filter (\x -> take 3 x == "cpu") . lines++tuplize :: [String] -> Maybe (String, [Int])+tuplize s = do+ cpu <- s `atMay` 0+ return (cpu, map (readDef (-1)) (tailSafe s))+
+ src/System/Taffybar/Information/DBusClients.hs view
@@ -0,0 +1,11 @@+{-# LANGUAGE TemplateHaskell #-}+module System.Taffybar.Information.DBusClients where++import DBus.Generation+import System.Taffybar.Information.DBusObjects++generateClient playerGenerationParams playerInterface+generateSignalsFromInterface playerGenerationParams playerInterface++generateClient playerGenerationParams mprisInterface+generateSignalsFromInterface playerGenerationParams mprisInterface
+ src/System/Taffybar/Information/DBusObjects.hs view
@@ -0,0 +1,34 @@+{-# LANGUAGE OverloadedStrings #-}+module System.Taffybar.Information.DBusObjects where++import System.IO.Unsafe+import DBus.Generation+import DBus.Introspection+import Data.Maybe++{-# NOINLINE playerObject #-}+playerObject :: Object+playerObject = unsafePerformIO $+ head . maybeToList . parseXML "/" <$>+ readFile "dbus-xml/org.mpris.MediaPlayer2.Player.xml"++playerInterface :: Interface+playerInterface =+ head $ objectInterfaces playerObject++{-# NOINLINE mprisObject #-}+mprisObject :: Object+mprisObject = unsafePerformIO $+ head . maybeToList . parseXML "/" <$>+ readFile "dbus-xml/org.mpris.MediaPlayer2.xml"++mprisInterface :: Interface+mprisInterface =+ head $ objectInterfaces mprisObject++playerGenerationParams :: GenerationParams+playerGenerationParams =+ defaultGenerationParams+ { genTakeSignalErrorHandler = True+ , genObjectPath = Just "/org/mpris/MediaPlayer2"+ }
+ src/System/Taffybar/Information/DiskIO.hs view
@@ -0,0 +1,42 @@+-----------------------------------------------------------------------------+-- |+-- Module : System.Taffybar.Information.DiskIO+-- Copyright : (c) José A. Romero L.+-- License : BSD3-style (see LICENSE)+--+-- Maintainer : José A. Romero L. <escherdragon@gmail.com>+-- Stability : unstable+-- Portability : unportable+--+-- Provides information about read/write operations in a given disk or+-- partition, obtained from parsing the @\/proc\/diskstats@ file with some+-- of the facilities included in the "System.Taffybar.Information.StreamInfo" module.+-----------------------------------------------------------------------------++module System.Taffybar.Information.DiskIO ( getDiskTransfer ) where++import Data.Maybe ( mapMaybe )+import Safe ( atMay, headMay, readDef )+import System.Taffybar.Information.StreamInfo ( getParsedInfo, getTransfer )++-- | Returns a two-element list containing the speed of transfer for read and+-- write operations performed in the given disk\/partition (e.g. \"sda\",+-- \"sda1\").+getDiskTransfer :: String -> IO [Double]+getDiskTransfer disk = getTransfer 0.05 $ getDiskInfo disk++-- | Returns the list of all the values available in @\/proc\/diskstats@+-- for the given disk or partition.+getDiskInfo :: String -> IO [Int]+getDiskInfo = getParsedInfo "/proc/diskstats" parse++parse :: String -> [(String, [Int])]+parse = mapMaybe (tuplize . (drop 2 . words)) . lines++tuplize :: [String] -> Maybe (String, [Int])+tuplize s = do+ device <- headMay s+ used <- s `atMay` 3+ capacity <- s `atMay` 7+ return (device, [readDef (-1) used, readDef (-1) capacity])+
+ src/System/Taffybar/Information/EWMHDesktopInfo.hs view
@@ -0,0 +1,224 @@+-----------------------------------------------------------------------------+-- |+-- Module : System.Taffybar.Information.EWMHDesktopInfo+-- Copyright : (c) José A. Romero L.+-- License : BSD3-style (see LICENSE)+--+-- Maintainer : José A. Romero L. <escherdragon@gmail.com>+-- Stability : unstable+-- Portability : unportable+--+-- Functions to access data provided by the X11 desktop via EWHM hints. This+-- module requires that the EwmhDesktops hook from the XMonadContrib project+-- be installed in your @~\/.xmonad\/xmonad.hs@ configuration:+--+-- > import XMonad+-- > import XMonad.Hooks.EwmhDesktops (ewmh)+-- >+-- > main = xmonad $ ewmh $ ...+--+-----------------------------------------------------------------------------++module System.Taffybar.Information.EWMHDesktopInfo+ ( X11Window -- re-exported from X11DesktopInfo+ , X11WindowHandle+ , WorkspaceIdx(..)+ , EWMHIcon(..)+ , EWMHIconData+ , withDefaultCtx -- re-exported from X11DesktopInfo+ , isWindowUrgent -- re-exported from X11DesktopInfo+ , getCurrentWorkspace+ , getVisibleWorkspaces+ , getWorkspaceNames+ , switchToWorkspace+ , switchOneWorkspace+ , withEWMHIcons+ , getWindowTitle+ , getWindowClass+ , getWindowIconsData+ , getActiveWindowTitle+ , getWindows+ , getWindowHandles+ , getWorkspace+ , focusWindow+ ) where++import Control.Applicative+import Control.Monad.Trans+import Data.Maybe+import Data.Tuple+import Data.Word+import Debug.Trace+import Foreign.ForeignPtr+import Foreign.Marshal.Array+import Foreign.Ptr+import Foreign.Storable+import System.Taffybar.Information.SafeX11++import Prelude++import System.Taffybar.Information.X11DesktopInfo++-- | Convenience alias for a pair of the form (props, window), where props is a+-- tuple of the form (workspace index, window title, window class), and window+-- is the internal ID of an open window.+type X11WindowHandle = ((WorkspaceIdx, String, String), X11Window)++newtype WorkspaceIdx = WSIdx Int+ deriving (Show, Read, Ord, Eq)++-- A super annoying detail of the XGetWindowProperty interface is that: "If the+-- returned format is 32, the returned data is represented as a long array and+-- should be cast to that type to obtain the elements." This means that even+-- though only the 4 least significant bits will ever contain any data, the+-- array that is returned from X11 can have a larger word size. This means that+-- we need to manipulate the underlying data in annoying ways to pass it to gtk+-- appropriately.+type PixelsWordType = Word64++type EWMHIconData = (ForeignPtr PixelsWordType, Int)++data EWMHIcon = EWMHIcon+ { width :: Int+ , height :: Int+ , pixelsARGB :: Ptr PixelsWordType+ } deriving (Show, Eq)++noFocus :: String+noFocus = "..."++-- | Retrieve the index of the current workspace in the desktop,+-- starting from 0.+getCurrentWorkspace :: X11Property WorkspaceIdx+getCurrentWorkspace = WSIdx <$> readAsInt Nothing "_NET_CURRENT_DESKTOP"++-- | Retrieve the indexes of all currently visible workspaces+-- with the active workspace at the head of the list.+getVisibleWorkspaces :: X11Property [WorkspaceIdx]+getVisibleWorkspaces = do+ vis <- getVisibleTags+ allNames <- map swap <$> getWorkspaceNames+ cur <- getCurrentWorkspace+ return $ cur : mapMaybe (`lookup` allNames) vis++-- | Return a list with the names of all the workspaces currently+-- available.+getWorkspaceNames :: X11Property [(WorkspaceIdx, String)]+getWorkspaceNames = go <$> readAsListOfString Nothing "_NET_DESKTOP_NAMES"+ where go = zip [WSIdx i | i <- [0..]]++-- | Ask the window manager to switch to the workspace with the given+-- index, starting from 0.+switchToWorkspace :: WorkspaceIdx -> X11Property ()+switchToWorkspace (WSIdx idx) = do+ cmd <- getAtom "_NET_CURRENT_DESKTOP"+ sendCommandEvent cmd (fromIntegral idx)++-- | Move one workspace up or down from the current workspace+switchOneWorkspace :: Bool -> Int -> X11Property ()+switchOneWorkspace dir end = do+ cur <- getCurrentWorkspace+ switchToWorkspace $ if dir then getPrev cur end else getNext cur end++-- | Check for corner case and switch one workspace up+getPrev :: WorkspaceIdx -> Int -> WorkspaceIdx+getPrev (WSIdx idx) end+ | idx > 0 = WSIdx $ idx-1+ | otherwise = WSIdx end++-- | Check for corner case and switch one workspace down+getNext :: WorkspaceIdx -> Int -> WorkspaceIdx+getNext (WSIdx idx) end+ | idx < end = WSIdx $ idx+1+ | otherwise = WSIdx 0++-- | Get the title of the given X11 window.+getWindowTitle :: X11Window -> X11Property String+getWindowTitle window = do+ let w = Just window+ prop <- readAsString w "_NET_WM_NAME"+ case prop of+ "" -> readAsString w "WM_NAME"+ _ -> return prop++-- | Get the class of the given X11 window.+getWindowClass :: X11Window -> X11Property String+getWindowClass window = readAsString (Just window) "WM_CLASS"++-- | Get EWMHIconData for the given X11Window+getWindowIconsData :: X11Window -> X11Property (Maybe EWMHIconData)+getWindowIconsData window = do+ dpy <- getDisplay+ atom <- getAtom "_NET_WM_ICON"+ 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+ iwidth <- fromIntegral <$> peek arr+ iheight <- fromIntegral <$> peekElemOff arr 1+ let pixelsPtr = advancePtr arr 2+ thisSize = iwidth * iheight+ newArr = advancePtr pixelsPtr thisSize+ thisIcon =+ EWMHIcon+ { width = iwidth+ , height = iheight+ , pixelsARGB = pixelsPtr+ }+ getRes newSize+ | newSize < 0 = trace "This should not happen parseIcons" return []+ | otherwise = (thisIcon :) <$> parseIcons newSize newArr -- Keep going+ getRes $ totalSize - fromIntegral (thisSize + 2)++withActiveWindow :: (X11Window -> X11Property String) -> X11Property String+withActiveWindow getProp = do+ awt <- readAsListOfWindow Nothing "_NET_ACTIVE_WINDOW"+ let w = listToMaybe $ filter (>0) awt+ maybe (return noFocus) getProp w++-- | Get the title of the currently focused window.+getActiveWindowTitle :: X11Property String+getActiveWindowTitle = withActiveWindow getWindowTitle++-- | Return a list of all windows+getWindows :: X11Property [X11Window]+getWindows = readAsListOfWindow Nothing "_NET_CLIENT_LIST"++-- | Return a list of X11 window handles, one for each window open. Refer to the+-- documentation of 'X11WindowHandle' for details on the structure returned.+getWindowHandles :: X11Property [X11WindowHandle]+getWindowHandles = do+ windows <- getWindows+ workspaces <- mapM getWorkspace windows+ wtitles <- mapM getWindowTitle windows+ wclasses <- mapM getWindowClass windows+ return $ zip (zip3 workspaces wtitles wclasses) windows++-- | Return the index (starting from 0) of the workspace on which the+-- given window is being displayed.+getWorkspace :: X11Window -> X11Property WorkspaceIdx+getWorkspace window = WSIdx <$> readAsInt (Just window) "_NET_WM_DESKTOP"++-- | Ask the window manager to give focus to the given window.+focusWindow :: X11Window -> X11Property ()+focusWindow wh = do+ cmd <- getAtom "_NET_ACTIVE_WINDOW"+ sendWindowEvent cmd (fromIntegral wh)
+ src/System/Taffybar/Information/MPRIS2.hs view
@@ -0,0 +1,70 @@+-----------------------------------------------------------------------------+-- |+-- Module : System.Taffybar.Information.MPRIS2+-- Copyright : (c) Ivan A. Malison+-- License : BSD3-style (see LICENSE)+--+-- Maintainer : Ivan A. Malison+-- Stability : unstable+-- Portability : unportable+--+-----------------------------------------------------------------------------++module System.Taffybar.Information.MPRIS2 where++import Control.Monad.Trans+import Control.Monad.Trans.Except+import Control.Monad.Trans.Maybe+import qualified DBus+import qualified DBus.Client as DBus+import qualified DBus.Internal.Types as DBus+import qualified DBus.TH as DBus+import Data.Coerce+import Data.List+import qualified Data.Map as M+import Data.Maybe+import System.Taffybar.Information.DBusClients+import System.Log.Logger+import Text.Printf++data NowPlaying = NowPlaying+ { npTitle :: String+ , npArtists :: [String]+ , npStatus :: String+ , npBusName :: DBus.BusName+ } deriving (Show, Eq)++eitherToMaybeWithLog :: (MonadIO m, Show a1) => Either a1 a2 -> m (Maybe a2)+eitherToMaybeWithLog (Right v) = return $ Just v+eitherToMaybeWithLog (Left e) = liftIO $ do+ logM "System.Taffybar.Information.MPRIS2" WARNING $+ printf "Got error: %s" $ show e+ return Nothing++getNowPlayingInfo :: MonadIO m => DBus.Client -> m [NowPlaying]+getNowPlayingInfo client =+ fmap (fromMaybe []) $ eitherToMaybeWithLog =<< liftIO (runExceptT $ do+ allBusNames <- ExceptT $ DBus.listNames client+ let mediaPlayerBusNames =+ filter (isPrefixOf "org.mpris.MediaPlayer2.") allBusNames+ getSongData _busName = runMaybeT $+ do+ let busName = coerce _busName+ metadataMap <-+ MaybeT $ getMetadata client busName >>= eitherToMaybeWithLog+ (title, artists) <- MaybeT $ return $ getSongInfo metadataMap+ status <- MaybeT $ getPlaybackStatus client busName >>=+ eitherToMaybeWithLog+ return NowPlaying { npTitle = title+ , npArtists = artists+ , npStatus = status+ , npBusName = busName+ }+ lift $ catMaybes <$> mapM getSongData mediaPlayerBusNames)++getSongInfo :: M.Map String DBus.Variant -> Maybe (String, [String])+getSongInfo songData = do+ let lookupVariant k = M.lookup k songData >>= DBus.fromVariant+ artists <- lookupVariant "xesam:artist"+ title <- lookupVariant "xesam:title"+ return (title, artists)
+ src/System/Taffybar/Information/Memory.hs view
@@ -0,0 +1,55 @@+module System.Taffybar.Information.Memory (+ MemoryInfo(..),+ parseMeminfo+ ) where++toMB :: String -> Double+toMB size = (read size :: Double) / 1024++data MemoryInfo = MemoryInfo+ { memoryTotal :: Double+ , memoryFree :: Double+ , memoryBuffer :: Double+ , memoryCache :: Double+ , memorySwapTotal :: Double+ , memorySwapFree :: Double+ , memorySwapUsed :: Double -- swapTotal - swapFree+ , memorySwapUsedRatio :: Double -- swapUsed / swapTotal+ , memoryAvailable :: Double -- An estimate of how much memory is available for starting new apps+ , memoryRest :: Double -- free + buffer + cache+ , memoryUsed :: Double -- total - rest+ , memoryUsedRatio :: Double -- used / total+ }++emptyMemoryInfo :: MemoryInfo+emptyMemoryInfo = MemoryInfo 0 0 0 0 0 0 0 0 0 0 0 0++parseLines :: [String] -> MemoryInfo -> MemoryInfo+parseLines (line:rest) memInfo = parseLines rest newMemInfo+ where (label:size:_) = words line+ newMemInfo = case label of+ "MemTotal:" -> memInfo { memoryTotal = toMB size }+ "MemFree:" -> memInfo { memoryFree = toMB size }+ "MemAvailable:" -> memInfo { memoryAvailable = toMB size }+ "Buffers:" -> memInfo { memoryBuffer = toMB size }+ "Cached:" -> memInfo { memoryCache = toMB size }+ "SwapTotal:" -> memInfo { memorySwapTotal = toMB size }+ "SwapFree:" -> memInfo { memorySwapFree = toMB size }+ _ -> memInfo+parseLines _ memInfo = memInfo++parseMeminfo :: IO MemoryInfo+parseMeminfo = do+ s <- readFile "/proc/meminfo"+ let m = parseLines (lines s) emptyMemoryInfo+ rest = memoryFree m + memoryBuffer m + memoryCache m+ used = memoryTotal m - rest+ usedRatio = used / memoryTotal m+ swapUsed = memorySwapTotal m - memorySwapFree m+ swapUsedRatio = swapUsed / memorySwapTotal m+ return m { memoryRest = rest+ , memoryUsed = used+ , memoryUsedRatio = usedRatio+ , memorySwapUsed = swapUsed+ , memorySwapUsedRatio = swapUsedRatio+ }
+ src/System/Taffybar/Information/Network.hs view
@@ -0,0 +1,141 @@+-----------------------------------------------------------------------------+-- |+-- Module : System.Taffybar.Information.Network+-- Copyright : (c) José A. Romero L.+-- License : BSD3-style (see LICENSE)+--+-- Maintainer : José A. Romero L. <escherdragon@gmail.com>+-- Stability : unstable+-- Portability : unportable+--+-- Provides information about network traffic over selected interfaces,+-- obtained from parsing the @\/proc\/net\/dev@ file using some of the+-- facilities provided by the "System.Taffybar.Information.StreamInfo" module.+--+-----------------------------------------------------------------------------++module System.Taffybar.Information.Network where++import Control.Applicative+import qualified Control.Concurrent.MVar as MV+import Control.Exception (catch, SomeException)+import Control.Monad+import Control.Monad.Trans+import Control.Monad.Trans.Maybe (MaybeT(..))+import Data.Maybe ( mapMaybe )+import Data.Time.Clock+import Data.Time.Clock.System+import Safe ( atMay, initSafe, readDef )+import System.Taffybar.Information.StreamInfo ( getParsedInfo )+import System.Taffybar.Util++import Prelude++networkInfoFile :: FilePath+networkInfoFile = "/proc/net/dev"++-- | Returns a two-element list containing the current number of bytes received+-- and transmitted via the given network interface (e.g. \"wlan0\"), according+-- to the contents of the @\/proc\/dev\/net@ file.+getNetInfo :: String -> IO (Maybe [Int])+getNetInfo iface = runMaybeT $ do+ isInterfaceUp iface+ handleFailure $ getParsedInfo networkInfoFile parseDevNet' iface++parseDevNet' :: String -> [(String, [Int])]+parseDevNet' input =+ map makeList $ parseDevNet input+ where makeList (a, (u, d)) = (a, [u, d])++parseDevNet :: String -> [(String, (Int, Int))]+parseDevNet = mapMaybe (getDeviceUpDown . words) . drop 2 . lines++getDeviceUpDown :: [String] -> Maybe (String, (Int, Int))+getDeviceUpDown s = do+ dev <- initSafe <$> s `atMay` 0+ down <- readDef (-1) <$> s `atMay` 1+ up <- readDef (-1) <$> s `atMay` out+ return (dev, (down, up))+ where+ out = length s - 8++-- Nothing if interface does not exist or is down+isInterfaceUp :: String -> MaybeT IO ()+isInterfaceUp iface = do+ state <- handleFailure $ readFile $ "/sys/class/net/" ++ iface ++ "/operstate"+ case state of+ 'u' : _ -> return ()+ _ -> mzero++handleFailure :: IO a -> MaybeT IO a+handleFailure action = MaybeT $ catch (Just <$> action) eToNothing+ where+ eToNothing :: SomeException -> IO (Maybe a)+ eToNothing _ = pure Nothing++getDeviceSamples :: IO (Maybe [TxSample])+getDeviceSamples = runMaybeT $ handleFailure $ do+ contents <- readFile networkInfoFile+ length contents `seq` return ()+ time <- liftIO getSystemTime+ let mkSample (device, (up, down)) =+ TxSample { sampleUp = up+ , sampleDown = down+ , sampleTime = time+ , sampleDevice = device+ }+ return $ map mkSample $ parseDevNet contents++data TxSample = TxSample+ { sampleUp :: Int+ , sampleDown :: Int+ , sampleTime :: SystemTime+ , sampleDevice :: String+ } deriving (Show, Eq)++monitorNetworkInterfaces+ :: RealFrac a1+ => a1 -> ([(String, (Rational, Rational))] -> IO ()) -> IO ()+monitorNetworkInterfaces interval onUpdate = void $ do+ samplesVar <- MV.newMVar []+ let sampleToSpeeds (device, (s1, s2)) = (device, getSpeed s1 s2)+ doOnUpdate samples = do+ let speedInfo = map sampleToSpeeds samples+ onUpdate speedInfo+ return samples+ doUpdate = MV.modifyMVar_ samplesVar ((>>= doOnUpdate) . updateSamples)+ foreverWithDelay interval doUpdate++updateSamples :: [(String, (TxSample, TxSample))] -> IO [(String, (TxSample, TxSample))]+updateSamples currentSamples = do+ let getLast sample@TxSample { sampleDevice = device } =+ maybe sample fst $ lookup device currentSamples+ getSamplePair sample@TxSample { sampleDevice = device } =+ (device, (sample, getLast sample))+ maybe currentSamples (map getSamplePair) <$> getDeviceSamples++getSpeed :: TxSample -> TxSample -> (Rational, Rational)+getSpeed TxSample { sampleUp = thisUp+ , sampleDown = thisDown+ , sampleTime = thisTime+ }+ TxSample { sampleUp = lastUp+ , sampleDown = lastDown+ , sampleTime = lastTime+ } =+ let intervalDiffTime =+ diffUTCTime+ (systemToUTCTime thisTime)+ (systemToUTCTime lastTime)+ intervalRatio =+ if intervalDiffTime == 0+ then 0+ else toRational $ 1 / intervalDiffTime+ in ( fromIntegral (thisDown - lastDown) * intervalRatio+ , fromIntegral (thisUp - lastUp) * intervalRatio+ )++sumSpeeds :: [(Rational, Rational)] -> (Rational, Rational)+sumSpeeds = foldr1 sumOne+ where+ sumOne (d1, u1) (d2, u2) = (d1 + d2, u1 + u2)
+ src/System/Taffybar/Information/SafeX11.hsc view
@@ -0,0 +1,218 @@+{-# LANGUAGE MultiParamTypeClasses, StandaloneDeriving, FlexibleInstances,+ InterruptibleFFI, ExistentialQuantification, DeriveDataTypeable #-}+-----------------------------------------------------------------------------+-- |+-- Module : System.Taffybar.Information.SafeX11+-- Copyright : (c) Ivan A. Malison+-- License : BSD3-style (see LICENSE)+--+-- Maintainer : Ivan A. Malison+-- Stability : unstable+-- Portability : unportable+-----------------------------------------------------------------------------+module System.Taffybar.Information.SafeX11+ ( module Graphics.X11.Xlib+ , module Graphics.X11.Xlib.Extras+ , module System.Taffybar.Information.SafeX11+ )+ where++import Control.Concurrent+import Control.Exception+import Control.Monad+import Control.Monad.Trans+import Control.Monad.Trans.Maybe (MaybeT(..))+import Data.Either.Combinators+import Data.Typeable+import Foreign hiding (void)+import Foreign.C.Types+import GHC.ForeignPtr+import Graphics.X11.Xlib+import Graphics.X11.Xlib.Extras+ hiding (rawGetWindowProperty, getWindowProperty8,+ getWindowProperty16, getWindowProperty32,+ xGetWMHints, getWMHints, refreshKeyboardMapping)+import Prelude+import System.IO+import System.IO.Unsafe+import System.Timeout++foreign import ccall safe "XlibExtras.h XGetWMHints"+ safeXGetWMHints :: Display -> Window -> IO (Ptr WMHints)++foreign import ccall interruptible "XlibExtras.h XGetWindowProperty"+ safeXGetWindowProperty ::+ Display ->+ Window ->+ Atom ->+ CLong ->+ CLong ->+ Bool ->+ Atom ->+ Ptr Atom ->+ Ptr CInt ->+ Ptr CULong ->+ Ptr CULong ->+ Ptr (Ptr CUChar) -> IO Status++rawGetWindowPropertyBytes+ :: Storable a+ => Int -> Display -> Atom -> Window -> IO (Maybe (ForeignPtr a, Int))+rawGetWindowPropertyBytes bits d atom w =+ alloca $ \actual_type_return ->+ alloca $ \actual_format_return ->+ alloca $ \nitems_return ->+ alloca $ \bytes_after_return ->+ alloca $ \prop_return -> do+ ret <- postX11RequestSync $+ safeXGetWindowProperty+ d+ w+ atom+ 0+ 0xFFFFFFFF+ False+ anyPropertyType+ actual_type_return+ actual_format_return+ nitems_return+ bytes_after_return+ prop_return+ if fromRight (-1) ret /= 0+ then return Nothing+ else do+ prop_ptr <- peek prop_return+ actual_format <- fromIntegral `fmap` peek actual_format_return+ nitems <- fromIntegral `fmap` peek nitems_return+ getprop prop_ptr nitems actual_format+ where+ getprop prop_ptr nitems actual_format+ | actual_format == 0 = return Nothing -- Property not found+ | actual_format /= bits = xFree prop_ptr >> return Nothing+ | otherwise = do+ ptr <- newConcForeignPtr (castPtr prop_ptr) (void $ xFree prop_ptr)+ return $ Just (ptr, nitems)++data SafeX11Exception = SafeX11Exception deriving (Show, Eq, Typeable)++instance Exception SafeX11Exception++data IORequest = forall a. IORequest+ { ioAction :: IO a+ , ioResponse :: Chan (Either SafeX11Exception a)+ }++{-# NOINLINE requestQueue #-}+requestQueue :: Chan IORequest+requestQueue = unsafePerformIO newChan++{-# NOINLINE x11Thread #-}+x11Thread :: ThreadId+x11Thread = unsafePerformIO $ forkIO startHandlingX11Requests++withErrorHandler :: XErrorHandler -> IO a -> IO a+withErrorHandler new_handler action = do+ handler <- mkXErrorHandler (\d e -> new_handler d e >> return 0)+ original <- _xSetErrorHandler handler+ res <- action+ _ <- _xSetErrorHandler original+ return res++deriving instance Show ErrorEvent++startHandlingX11Requests :: IO ()+startHandlingX11Requests =+ withErrorHandler handleError handleX11Requests+ where handleError _ xerrptr = do+ putStrLn "Got error"+ ee <- getErrorEvent xerrptr+ print ee++handleX11Requests :: IO ()+handleX11Requests = do+ IORequest {ioAction = action, ioResponse = responseChannel} <-+ readChan requestQueue+ res <-+ catch+ (maybe (Left SafeX11Exception) Right <$> timeout 500000 action)+ (\e -> do+ putStrLn "Got error on X11 thread"+ hFlush stdout+ print (e :: IOException)+ return $ Left SafeX11Exception)+ writeChan responseChannel res+ handleX11Requests+ return ()++postX11RequestSync :: IO a -> IO (Either SafeX11Exception a)+postX11RequestSync action = do+ let postAndWait = do+ responseChannel <- newChan :: IO (Chan (Either SafeX11Exception a))+ writeChan+ requestQueue+ IORequest {ioAction = action, ioResponse = responseChannel}+ readChan responseChannel+ currentTID <- myThreadId+ if currentTID == x11Thread+ then Right <$> action+ else postAndWait++postX11RequestSyncDef :: a -> IO a -> IO a+postX11RequestSyncDef def action =+ fromRight def <$> postX11RequestSync action++rawGetWindowProperty ::+ Storable a+ => Int -> Display -> Atom -> Window -> IO (Maybe [a])+rawGetWindowProperty bits d atom w =+ runMaybeT $ do+ (ptr, count) <- MaybeT $ rawGetWindowPropertyBytes bits d atom w+ lift $ withForeignPtr ptr $ peekArray count++getWindowProperty8 :: Display -> Atom -> Window -> IO (Maybe [CChar])+getWindowProperty8 = rawGetWindowProperty 8++getWindowProperty16 :: Display -> Atom -> Window -> IO (Maybe [CShort])+getWindowProperty16 = rawGetWindowProperty 16++getWindowProperty32 :: Display -> Atom -> Window -> IO (Maybe [CLong])+getWindowProperty32 = rawGetWindowProperty 32++getWMHints :: Display -> Window -> IO WMHints+getWMHints dpy w = do+ p <- safeXGetWMHints dpy w+ if p == nullPtr+ then return $ WMHints 0 False 0 0 0 0 0 0 0+ else do x <- peek p; _ <- xFree p; return x++safeGetGeometry :: Display -> Drawable ->+ IO (Window, Position, Position, Dimension, Dimension, Dimension, CInt)+safeGetGeometry display d =+ outParameters7 (throwIfZero "getGeometry") $+ xGetGeometry display d++outParameters7 :: (Storable a, Storable b, Storable c, Storable d, Storable e, Storable f, Storable g) =>+ (IO r -> IO ()) -> (Ptr a -> Ptr b -> Ptr c -> Ptr d -> Ptr e -> Ptr f -> Ptr g -> IO r) ->+ IO (a,b,c,d,e,f,g)+outParameters7 check fn =+ alloca $ \ a_return ->+ alloca $ \ b_return ->+ alloca $ \ c_return ->+ alloca $ \ d_return ->+ alloca $ \ e_return ->+ alloca $ \ f_return ->+ alloca $ \ g_return -> do+ check (fn a_return b_return c_return d_return e_return f_return g_return)+ a <- peek a_return+ b <- peek b_return+ c <- peek c_return+ d <- peek d_return+ e <- peek e_return+ f <- peek f_return+ g <- peek g_return+ return (a,b,c,d,e,f,g)++foreign import ccall safe "HsXlib.h XGetGeometry"+ xGetGeometry :: Display -> Drawable ->+ Ptr Window -> Ptr Position -> Ptr Position -> Ptr Dimension ->+ Ptr Dimension -> Ptr Dimension -> Ptr CInt -> IO Status
+ src/System/Taffybar/Information/StreamInfo.hs view
@@ -0,0 +1,89 @@+--------------------------------------------------------------------------------+-- |+-- Module : System.Taffybar.Information.StreamInfo+-- Copyright : (c) José A. Romero L.+-- License : BSD3-style (see LICENSE)+--+-- Maintainer : José A. Romero L. <escherdragon@gmail.com>+-- Stability : unstable+-- Portability : unportable+--+-- Generic code to poll any of the many data files maintained by the kernel in+-- POSIX systems. Provides methods for applying a custom parsing function to the+-- contents of the file and to calculate differentials across one or more values+-- provided via the file.+--+--------------------------------------------------------------------------------++module System.Taffybar.Information.StreamInfo+ ( getParsedInfo+ , getLoad+ , getAccLoad+ , getTransfer+ ) where++import Control.Concurrent ( threadDelay )+import Data.IORef+import Data.Maybe ( fromMaybe )++-- | Apply the given parser function to the file under the given path to produce+-- a lookup map, then use the given selector as key to extract from it the+-- desired value.+getParsedInfo :: FilePath -> (String -> [(String, [a])]) -> String -> IO [a]+getParsedInfo path parser selector = do+ file <- readFile path+ length file `seq` return ()+ return (fromMaybe [] $ lookup selector $ parser file)++truncVal :: (RealFloat a) => a -> a+truncVal v+ | isNaN v || v < 0.0 = 0.0+ | otherwise = v++-- | Convert the given list of Integer to a list of the ratios of each of its+-- elements against their sum.+toRatioList :: (Integral a, RealFloat b) => [a] -> [b]+toRatioList deltas = map truncVal ratios+ where total = fromIntegral $ sum deltas+ ratios = map ((/total) . fromIntegral) deltas++-- | Execute the given action twice with the given delay in-between and return+-- the difference between the two samples.+probe :: (Num a, RealFrac b) => IO [a] -> b -> IO [a]+probe action delay = do+ a <- action+ threadDelay $ round (delay * 1e6)+ b <- action+ return $ zipWith (-) b a++-- | Execute the given action once and return the difference between the+-- obtained sample and the one contained in the given IORef.+accProbe :: (Num a) => IO [a] -> IORef [a] -> IO [a]+accProbe action sample = do+ a <- readIORef sample+ b <- action+ writeIORef sample b+ return $ zipWith (-) b a++-- | Probe the given action and, interpreting the result as a variation in time,+-- return the speed of change of its values.+getTransfer :: (Integral a, RealFloat b) => b -> IO [a] -> IO [b]+getTransfer interval action = do+ deltas <- probe action interval+ return $ map (truncVal . (/interval) . fromIntegral) deltas++-- | Probe the given action and return the relative variation of each of the+-- obtained values against the whole, where the whole is calculated as the sum+-- of all the values in the probe.+getLoad :: (Integral a, RealFloat b) => b -> IO [a] -> IO [b]+getLoad interval action = do+ deltas <- probe action interval+ return $ toRatioList deltas++-- | Similar to getLoad, but execute the given action only once and use the+-- given IORef to calculate the result and to save the current value, so it+-- can be reused in the next call.+getAccLoad :: (Integral a, RealFloat b) => IORef [a] -> IO [a] -> IO [b]+getAccLoad sample action = do+ deltas <- accProbe action sample+ return $ toRatioList deltas
+ src/System/Taffybar/Information/Volume.hs view
@@ -0,0 +1,40 @@+module System.Taffybar.Information.Volume+ ( getVolume+ , setVolume+ ) where++import Sound.ALSA.Mixer++volumeAct :: String -> String -> (Volume -> Integer -> Integer -> IO a) -> IO a+volumeAct mix channel action = withMixer mix $ \mixer -> do+ Just control <- getControlByName mixer channel+ let Just playbackVolume = playback $ volume control+ (lo, hi) <- getRange playbackVolume+ action playbackVolume lo hi++-- | Gets volume of a channel of a mixer+getVolume :: String -> String -> IO Integer+getVolume mix channel = volumeAct mix channel $ \playbackVolume lo hi -> do+ Just vol <- getChannel FrontLeft $ value playbackVolume+ return $ toPercent vol lo hi++-- | Sets volume of a channel of a mixer+setVolume :: String -> String -> Double -> IO ()+setVolume mix channel vol = volumeAct mix channel $ \playbackVolume lo hi -> do+ let volumeValue = value playbackVolume+ percentage = fromPercent vol lo hi+ setForChannel c = setChannel c volumeValue percentage+ mapM_ setForChannel allChannels++toPercent :: Integer -> Integer -> Integer -> Integer+toPercent v lo hi = ceiling $ (v' - lo') / (hi' - lo') * 100+ where+ v' :: Double+ v' = fromIntegral v+ lo' = fromIntegral lo+ hi' = fromIntegral hi++fromPercent :: Double -> Integer -> Integer -> Integer+fromPercent v lo hi = ceiling $ lo' + (hi' - lo') * v / 100+ where lo' = fromIntegral lo+ hi' = fromIntegral hi
+ src/System/Taffybar/Information/X11DesktopInfo.hs view
@@ -0,0 +1,285 @@+-----------------------------------------------------------------------------+-- |+-- Module : System.Taffybar.Information.X11DesktopInfo+-- Copyright : (c) José A. Romero L.+-- License : BSD3-style (see LICENSE)+--+-- Maintainer : José A. Romero L. <escherdragon@gmail.com>+-- Stability : unstable+-- Portability : unportable+--+-- Low-level functions to access data provided by the X11 desktop via window+-- properties. One of them ('getVisibleTags') depends on the PagerHints hook+-- being installed in your @~\/.xmonad\/xmonad.hs@ configuration:+--+-- > import System.Taffybar.Support.PagerHints (pagerHints)+-- >+-- > main = xmonad $ ewmh $ pagerHints $ ...+--+-----------------------------------------------------------------------------++module System.Taffybar.Information.X11DesktopInfo+ ( X11Context(..)+ , X11Property+ , X11Window+ , doLowerWindow+ , eventLoop+ , getAtom+ , getDefaultCtx+ , getDisplay+ , getPrimaryOutputNumber+ , getVisibleTags+ , getWindowState+ , getWindowStateProperty+ , isWindowUrgent+ , postX11RequestSyncProp+ , readAsInt+ , readAsListOfInt+ , readAsListOfString+ , readAsListOfWindow+ , readAsString+ , sendCommandEvent+ , sendWindowEvent+ , withDefaultCtx+ ) where++import Data.List+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)+import Graphics.X11.Xlib+import Graphics.X11.Xlib.Extras+ hiding (getWindowProperty8, getWindowProperty32, getWMHints)+import Graphics.X11.Xrandr+import Prelude+import System.Taffybar.Information.SafeX11++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])++-- | Put the current display and root window objects inside a Reader+-- transformer for further computation.+withDefaultCtx :: X11Property a -> IO a+withDefaultCtx fun = do+ ctx <- getDefaultCtx+ res <- runReaderT fun ctx+ closeDisplay (contextDisplay ctx)+ return res++getDisplay :: X11Property Display+getDisplay = contextDisplay <$> ask++-- | Retrieve the property of the given window (or the root window,+-- if Nothing) with the given name as a value of type Int. If that+-- property hasn't been set, then return -1.+readAsInt :: Maybe X11Window -- ^ window to read from. Nothing means the root window.+ -> String -- ^ name of the property to retrieve+ -> X11Property Int+readAsInt window name = do+ prop <- fetch getWindowProperty32 window name+ case prop of+ Just (x:_) -> return (fromIntegral x)+ _ -> return (-1)++-- | Retrieve the property of the given window (or the root window,+-- if Nothing) with the given name as a list of Ints. If that+-- property hasn't been set, then return an empty list.+readAsListOfInt :: Maybe X11Window -- ^ window to read from. Nothing means the root window.+ -> String -- ^ name of the property to retrieve+ -> X11Property [Int]+readAsListOfInt window name = do+ prop <- fetch getWindowProperty32 window name+ case prop of+ Just xs -> return (map fromIntegral xs)+ _ -> return []++-- | Retrieve the property of the given window (or the root window,+-- if Nothing) with the given name as a String. If the property+-- hasn't been set, then return an empty string.+readAsString :: Maybe X11Window -- ^ window to read from. Nothing means the root window.+ -> String -- ^ name of the property to retrieve+ -> X11Property String+readAsString window name = do+ prop <- fetch getWindowProperty8 window name+ case prop of+ Just xs -> return . UTF8.decode . map fromIntegral $ xs+ _ -> return []++-- | Retrieve the property of the given window (or the root window,+-- if Nothing) with the given name as a list of Strings. If the+-- property hasn't been set, then return an empty list.+readAsListOfString :: Maybe X11Window -- ^ window to read from. Nothing means the root window.+ -> String -- ^ name of the property to retrieve+ -> X11Property [String]+readAsListOfString window name = do+ prop <- fetch getWindowProperty8 window name+ case prop of+ Just xs -> return (parse xs)+ _ -> return []+ where+ parse = endBy "\0" . UTF8.decode . map fromIntegral++-- | Retrieve the property of the given window (or the root window,+-- if Nothing) with the given name as a list of X11 Window IDs. If+-- the property hasn't been set, then return an empty list.+readAsListOfWindow :: Maybe X11Window -- ^ window to read from. Nothing means the root window.+ -> String -- ^ name of the property to retrieve+ -> X11Property [X11Window]+readAsListOfWindow window name = do+ prop <- fetch getWindowProperty32 window name+ case prop of+ Just xs -> return $ map fromIntegral xs+ _ -> return []++-- | Determine whether the \"urgent\" flag is set in the WM_HINTS of+-- the given window.+isWindowUrgent :: X11Window -> X11Property Bool+isWindowUrgent window = do+ hints <- fetchWindowHints window+ return $ testBit (wmh_flags hints) urgencyHintBit++-- | Retrieve the value of the special _XMONAD_VISIBLE_WORKSPACES hint set+-- by the PagerHints hook provided by Taffybar (see module documentation for+-- instructions on how to do this), or an empty list of strings if the+-- PagerHints hook is not available.+getVisibleTags :: X11Property [String]+getVisibleTags = readAsListOfString Nothing "_XMONAD_VISIBLE_WORKSPACES"++-- | Return the Atom with the given name.+getAtom :: String -> X11Property Atom+getAtom s = do+ (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+-- arrives, and subscribing to all events of this type emitted by newly+-- created windows.+eventLoop :: (Event -> IO ()) -> X11Property ()+eventLoop dispatch = do+ (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 { ev_window = window } ->+ selectInput d window propertyChangeMask+ _ -> return ()+ dispatch event++-- | Emit a \"command\" event with one argument for the X server. This is+-- used to send events that can be received by event hooks in the XMonad+-- process and acted upon in that context.+sendCommandEvent :: Atom -> Atom -> X11Property ()+sendCommandEvent cmd arg = do+ (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+ sendCustomEvent dpy cmd cmd root win++-- | Build a new X11Context containing the current X11 display and its root+-- window.+getDefaultCtx :: IO X11Context+getDefaultCtx = do+ d <- openDisplay ""+ w <- rootWindow d $ defaultScreen d+ cache <- MV.newMVar []+ return $ X11Context d w cache++getWindowStateProperty :: X11Window -> String -> X11Property Bool+getWindowStateProperty window property = not . null <$> getWindowState window [property]++getWindowState :: X11Window -> [String] -> X11Property [String]+getWindowState window request = do+ let getAsLong s = fromIntegral <$> getAtom s+ integers <- mapM getAsLong request+ properties <- fetch getWindowProperty32 (Just window) "_NET_WM_STATE"+ let integerToString = zip integers request+ present = intersect integers $ fromMaybe [] properties+ presentStrings = map (`lookup` integerToString) present+ return $ catMaybes presentStrings++-- | Apply the given function to the given window in order to obtain the X11+-- property with the given name, or Nothing if no such property can be read.+fetch :: (Integral a)+ => PropertyFetcher a -- ^ Function to use to retrieve the property.+ -> Maybe X11Window -- ^ Window to read from. Nothing means the root Window.+ -> String -- ^ Name of the property to retrieve.+ -> X11Property (Maybe [a])+fetch fetcher window name = do+ (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+ liftIO $ getWMHints d window++-- | Emit an event of type @ClientMessage@ that can be listened to and+-- consumed by XMonad event hooks.+sendCustomEvent :: Display+ -> Atom+ -> Atom+ -> X11Window+ -> X11Window+ -> X11Property ()+sendCustomEvent dpy cmd arg root win =+ liftIO $ allocaXEvent $ \e -> do+ setEventType e clientMessage+ setClientMessageEvent e win cmd 32 arg currentTime+ sendEvent dpy root False structureNotifyMask e+ sync dpy False++postX11RequestSyncProp :: X11Property a -> a -> X11Property a+postX11RequestSyncProp prop def = do+ c <- ask+ let action = runReaderT prop c+ lift $ postX11RequestSyncDef def action++isActiveOutput :: XRRScreenResources -> RROutput -> X11Property Bool+isActiveOutput sres output = do+ (X11Context display _ _) <- ask+ maybeOutputInfo <- liftIO $ xrrGetOutputInfo display sres output+ return $ maybe 0 xrr_oi_crtc maybeOutputInfo /= 0++getActiveOutputs :: X11Property [RROutput]+getActiveOutputs = do+ (X11Context display rootw _) <- ask+ maybeSres <- liftIO $ xrrGetScreenResources display rootw+ maybe (return []) (\sres -> filterM (isActiveOutput sres) $ xrr_sr_outputs sres)+ maybeSres++-- | Get the index of the primary monitor as set and ordered by Xrandr.+getPrimaryOutputNumber :: X11Property (Maybe Int)+getPrimaryOutputNumber = do+ (X11Context display rootw _) <- ask+ primary <- liftIO $ xrrGetOutputPrimary display rootw+ outputs <- getActiveOutputs+ return $ primary `elemIndex` outputs++doLowerWindow :: X11Window -> X11Property ()+doLowerWindow window =+ asks contextDisplay >>= lift . flip lowerWindow window
+ src/System/Taffybar/Information/XDG/DesktopEntry.hs view
@@ -0,0 +1,215 @@+-----------------------------------------------------------------------------+-- |+-- Module : System.Taffybar.Information.XDG.DesktopEntry+-- Copyright : 2017 Ulf Jasper+-- License : BSD3-style (see LICENSE)+--+-- Maintainer : Ulf Jasper <ulf.jasper@web.de>+-- Stability : unstable+-- Portability : unportable+--+-- Implementation of version 1.1 of the freedesktop "Desktop Entry+-- specification", see+-- https://specifications.freedesktop.org/desktop-entry-spec/desktop-entry-spec-1.1.html.+-----------------------------------------------------------------------------++module System.Taffybar.Information.XDG.DesktopEntry+ ( DesktopEntry(..)+ , deCommand+ , deComment+ , deHasCategory+ , deIcon+ , deName+ , deNoDisplay+ , deNotShowIn+ , deOnlyShowIn+ , existingDirs+ , getDefaultDataHome+ , getDirectoryEntry+ , getDirectoryEntryDefault+ , getXDGDataDirs+ , listDesktopEntries+ ) where++import Control.Monad.Except+import Data.Char+import qualified Data.ConfigFile as CF+import Data.List+import Data.Maybe+import qualified Data.Set as S+import System.Directory+import System.Environment+import System.FilePath.Posix+import System.Log.Logger+import System.Posix.Files+import Text.Printf++data DesktopEntryType = Application | Link | Directory+ deriving (Read, Show, Eq)++existingDirs :: [FilePath] -> IO [FilePath]+existingDirs dirs = do+ exs <- mapM fileExist dirs+ return $ S.toList $ S.fromList $ map fst $ filter snd $ zip dirs exs++getDefaultDataHome :: IO FilePath+getDefaultDataHome = do+ h <- getHomeDirectory+ return $ h </> ".local" </> "share"++-- XXX: We really ought to use+-- https://hackage.haskell.org/package/directory-1.3.2.2/docs/System-Directory.html#v:getXdgDirectory+getXDGDataDirs :: IO [FilePath]+getXDGDataDirs = do+ dataHome <- lookupEnv "XDG_DATA_HOME" >>= maybe getDefaultDataHome return+ dataDirs <- map normalise . splitSearchPath . fromMaybe "" <$>+ lookupEnv "XDG_DATA_DIRS"+ nubBy equalFilePath <$>+ existingDirs ( dataHome:dataDirs+ ++ ["/usr/local/share", "/usr/share"]+ )++-- | Desktop Entry. All attributes (key-value-pairs) are stored in an+-- association list.+data DesktopEntry = DesktopEntry+ { deType :: DesktopEntryType+ , deFilename :: FilePath -- ^ unqualified filename, e.g. "taffybar.desktop"+ , deAttributes :: [(String, String)] -- ^ Key-value pairs+ } deriving (Read, Show, Eq)++-- | Determine whether the Category attribute of a desktop entry contains a+-- given value.+deHasCategory+ :: DesktopEntry -- ^ desktop entry+ -> String -- ^ category to be checked+ -> Bool+deHasCategory de cat =+ maybe False ((cat `elem`) . splitAtSemicolon) $+ lookup "Categories" (deAttributes de)++splitAtSemicolon :: String -> [String]+splitAtSemicolon = lines . map (\c -> if c == ';' then '\n' else c)++-- | Return the proper name of the desktop entry, depending on the list of+-- preferred languages.+deName+ :: [String] -- ^ Preferred languages+ -> DesktopEntry+ -> String+deName langs de = fromMaybe (deFilename de) $ deLocalisedAtt langs de "Name"++-- | Return the categories in which the entry shall be shown+deOnlyShowIn :: DesktopEntry -> [String]+deOnlyShowIn = maybe [] splitAtSemicolon . deAtt "OnlyShowIn"++-- | Return the categories in which the entry shall not be shown+deNotShowIn :: DesktopEntry -> [String]+deNotShowIn = maybe [] splitAtSemicolon . deAtt "NotShowIn"++-- | Return the value of the given attribute key+deAtt :: String -> DesktopEntry -> Maybe String+deAtt att = lookup att . deAttributes++-- | Return the Icon attribute+deIcon :: DesktopEntry -> Maybe String+deIcon = deAtt "Icon"++-- | Return True if the entry must not be displayed+deNoDisplay :: DesktopEntry -> Bool+deNoDisplay de = maybe False (("true" ==) . map toLower) $ deAtt "NoDisplay" de++deLocalisedAtt+ :: [String] -- ^ Preferred languages+ -> DesktopEntry+ -> String+ -> Maybe String+deLocalisedAtt langs de att =+ let localeMatches =+ mapMaybe (\l -> lookup (att ++ "[" ++ l ++ "]") (deAttributes de)) langs+ in if null localeMatches+ then lookup att $ deAttributes de+ else Just $ head localeMatches++-- | Return the proper comment of the desktop entry, depending on the list of+-- preferred languages.+deComment :: [String] -- ^ Preferred languages+ -> DesktopEntry+ -> Maybe String+deComment langs de = deLocalisedAtt langs de "Comment"++-- | Return the command defined by the given desktop entry.+-- TODO: should check the dbus thing.+-- TODO: are there "field codes", i.e. %<char> things, that+deCommand :: DesktopEntry -> Maybe String+deCommand de =+ reverse . dropWhile (== ' ') . reverse . takeWhile (/= '%') <$>+ lookup "Exec" (deAttributes de)++-- | Return a list of all desktop entries in the given directory.+listDesktopEntries+ :: String -- ^ The extension to use in the search+ -> FilePath -- ^ The filepath at which to search+ -> IO [DesktopEntry]+listDesktopEntries extension dir = do+ let normalizedDir = normalise dir+ ex <- doesDirectoryExist normalizedDir+ if ex+ then do+ files <-+ map (normalizedDir </>) . filter (\v -> v /= "." && v /= "..") <$>+ getDirectoryContents dir+ entries <-+ (nub . catMaybes) <$>+ mapM readDesktopEntry (filter (extension `isSuffixOf`) files)+ subDirs <- filterM doesDirectoryExist files+ subEntries <- concat <$> mapM (listDesktopEntries extension) subDirs+ return $ entries ++ subEntries+ else return []++-- XXX: This function doesn't recurse, but `listDesktopEntries` does. Why?+-- Shouldn't they really share logic...+-- | 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+ exFiles <- filterM doesFileExist $ map ((</> name) . normalise) dirs+ if null exFiles+ then return Nothing+ else readDesktopEntry $ head exFiles++getDirectoryEntryDefault :: String -> IO (Maybe DesktopEntry)+getDirectoryEntryDefault entry =+ fmap (</> "applications") <$> getXDGDataDirs >>=+ flip getDirectoryEntry (printf "%s.desktop" entry)++-- | Main section of a desktop entry file.+sectionMain :: String+sectionMain = "Desktop Entry"++-- | Read a desktop entry from a file.+readDesktopEntry :: FilePath -> IO (Maybe DesktopEntry)+readDesktopEntry fp = do+ ex <- doesFileExist fp+ if ex+ then doReadDesktopEntry fp+ else do+ putStrLn $ "File does not exist: '" ++ fp ++ "'"+ return Nothing+ where+ doReadDesktopEntry :: FilePath -> IO (Maybe DesktopEntry)+ doReadDesktopEntry f = do+ eResult <-+ runExceptT $ do+ cp <- join $ liftIO $ CF.readfile CF.emptyCP f+ 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+ }
+ src/System/Taffybar/Information/XDG/Protocol.hs view
@@ -0,0 +1,259 @@+-----------------------------------------------------------------------------+-- |+-- Module : System.Taffybar.Information.XDG.Protocol+-- Copyright : 2017 Ulf Jasper+-- License : BSD3-style (see LICENSE)+--+-- Maintainer : Ulf Jasper <ulf.jasper@web.de>+-- Stability : unstable+-- Portability : unportable+--+-- Implementation of version 1.1 of the XDG "Desktop Menu+-- Specification", see+-- https://specifications.freedesktop.org/menu-spec/menu-spec-1.1.html+---- specification, see+-- See also 'MenuWidget'.+--+-----------------------------------------------------------------------------+module System.Taffybar.Information.XDG.Protocol+ ( XDGMenu(..)+ , DesktopEntryCondition(..)+ , readXDGMenu+ , matchesCondition+ , getXDGDesktop+ , getDirectoryDirs+ , getApplicationEntries+ , getPreferredLanguages+ ) where++import Control.Applicative+import Control.Monad.Trans+import Control.Monad.Trans.Maybe+import Data.Char (toLower)+import Data.List+import Data.Maybe+import qualified Debug.Trace as D+import GHC.IO.Encoding+import Prelude+import Safe (headMay)+import System.Directory+import System.Environment+import System.FilePath.Posix+import System.Taffybar.Information.XDG.DesktopEntry+import System.Taffybar.Util+import Text.XML.Light+import Text.XML.Light.Helpers++-- Environment Variables++-- | Produce a list of config locations to search, starting with XDG_CONFIG_HOME+-- and XDG_CONFIG_DIRS, with fallback to /etc/xdg+getXDGConfigDirs :: IO [String]+getXDGConfigDirs = do+ ch <- lookupEnv "XDG_CONFIG_HOME"+ cd <- lookupEnv "XDG_CONFIG_DIRS"+ let dirs = catMaybes [ch]+ ++ maybe [] splitSearchPath cd+ exDirs <- existingDirs dirs+ return $ if null exDirs+ then ["/etc/xdg/"]+ else map normalise exDirs++getXDGMenuPrefix :: IO (Maybe String)+getXDGMenuPrefix = lookupEnv "XDG_MENU_PREFIX"++-- | Find filename(s) of the application menu(s).+getXDGMenuFilenames+ :: Maybe String -- ^ Overrides the value of the environment variable+ -- XDG_MENU_PREFIX. Specifies the prefix for the menu (e.g.+ -- 'Just "mate-"').+ -> IO [FilePath]+getXDGMenuFilenames mMenuPrefix = do+ configDirs <- getXDGConfigDirs+ maybePrefix <- (mMenuPrefix <|>) <$> getXDGMenuPrefix+ let maybeAddDash t = if last t == '-' then t else t ++ "-"+ dashedPrefix = maybe "" maybeAddDash maybePrefix+ return $ map (</> "menus" </> dashedPrefix ++ "applications.menu") configDirs++-- | XDG Menu, cf. "Desktop Menu Specification".+data XDGMenu = XDGMenu+ { xmAppDir :: Maybe String+ , xmDefaultAppDirs :: Bool -- Use $XDG_DATA_DIRS/applications+ , xmDirectoryDir :: Maybe String+ , xmDefaultDirectoryDirs :: Bool -- Use $XDG_DATA_DIRS/desktop-directories+ , xmLegacyDirs :: [String]+ , xmName :: String+ , xmDirectory :: String+ , xmOnlyUnallocated :: Bool+ , xmDeleted :: Bool+ , xmInclude :: Maybe DesktopEntryCondition+ , xmExclude :: Maybe DesktopEntryCondition+ , xmSubmenus :: [XDGMenu]+ , xmLayout :: [XDGLayoutItem]+ } deriving (Show)++data XDGLayoutItem =+ XliFile String | XliSeparator | XliMenu String | XliMerge String+ deriving(Show)++-- | Return a list of all available desktop entries for a given xdg menu.+getApplicationEntries+ :: [String] -- ^ Preferred languages+ -> XDGMenu+ -> IO [DesktopEntry]+getApplicationEntries langs xm = do+ defEntries <- if xmDefaultAppDirs xm+ then do dataDirs <- getXDGDataDirs+ putStrLn $ "DataDirs=" ++ show dataDirs+ concat <$> mapM (listDesktopEntries ".desktop" .+ (</> "applications")) dataDirs+ else return []+ return $ sortBy (\de1 de2 -> compare (map toLower (deName langs de1))+ (map toLower (deName langs de2))) defEntries++-- | Parse menu.+parseMenu :: Element -> Maybe XDGMenu+parseMenu elt =+ let appDir = getChildData "AppDir" elt+ defaultAppDirs = isJust $ getChildData "DefaultAppDirs" elt+ directoryDir = getChildData "DirectoryDir" elt+ defaultDirectoryDirs = isJust $ getChildData "DefaultDirectoryDirs" elt+ name = fromMaybe "Name?" $ getChildData "Name" elt+ dir = fromMaybe "Dir?" $ getChildData "Directory" elt+ onlyUnallocated =+ case ( getChildData "OnlyUnallocated" elt+ , getChildData "NotOnlyUnallocated" elt) of+ (Nothing, Nothing) -> False -- ?!+ (Nothing, Just _) -> False+ (Just _, Nothing) -> True+ (Just _, Just _) -> False -- ?!+ deleted = False -- FIXME+ include = parseConditions "Include" elt+ exclude = parseConditions "Exclude" elt+ layout = parseLayout elt+ subMenus = fromMaybe [] $ mapChildren "Menu" elt parseMenu+ in Just+ XDGMenu+ { xmAppDir = appDir+ , xmDefaultAppDirs = defaultAppDirs+ , xmDirectoryDir = directoryDir+ , xmDefaultDirectoryDirs = defaultDirectoryDirs+ , xmLegacyDirs = []+ , xmName = name+ , xmDirectory = dir+ , xmOnlyUnallocated = onlyUnallocated+ , xmDeleted = deleted+ , xmInclude = include+ , xmExclude = exclude+ , xmSubmenus = subMenus+ , xmLayout = layout -- FIXME+ }++-- | Parse Desktop Entry conditions for Include/Exclude clauses.+parseConditions :: String -> Element -> Maybe DesktopEntryCondition+parseConditions key elt = case findChild (unqual key) elt of+ Nothing -> Nothing+ Just inc -> doParseConditions (elChildren inc)+ where doParseConditions :: [Element] -> Maybe DesktopEntryCondition+ doParseConditions [] = Nothing+ doParseConditions [e] = parseSingleItem e+ doParseConditions elts = Just $ Or $ mapMaybe parseSingleItem elts++ parseSingleItem e = case qName (elName e) of+ "Category" -> Just $ Category $ strContent e+ "Filename" -> Just $ Filename $ strContent e+ "And" -> Just $ And $ mapMaybe parseSingleItem+ $ elChildren e+ "Or" -> Just $ Or $ mapMaybe parseSingleItem+ $ elChildren e+ "Not" -> case parseSingleItem (head (elChildren e)) of+ Nothing -> Nothing+ Just rule -> Just $ Not rule+ unknown -> D.trace ("Unknown Condition item: " ++ unknown) Nothing++-- | Combinable conditions for Include and Exclude statements.+data DesktopEntryCondition = Category String+ | Filename String+ | Not DesktopEntryCondition+ | And [DesktopEntryCondition]+ | Or [DesktopEntryCondition]+ | All+ | None+ deriving (Read, Show, Eq)++parseLayout :: Element -> [XDGLayoutItem]+parseLayout elt = case findChild (unqual "Layout") elt of+ Nothing -> []+ Just lt -> mapMaybe parseLayoutItem (elChildren lt)+ where parseLayoutItem :: Element -> Maybe XDGLayoutItem+ parseLayoutItem e = case qName (elName e) of+ "Separator" -> Just XliSeparator+ "Filename" -> Just $ XliFile $ strContent e+ unknown -> D.trace ("Unknown layout item: " ++ unknown) Nothing++-- | Determine whether a desktop entry fulfils a condition.+matchesCondition :: DesktopEntry -> DesktopEntryCondition -> Bool+matchesCondition de (Category cat) = deHasCategory de cat+matchesCondition de (Filename fn) = fn == deFilename de+matchesCondition de (Not cond) = not $ matchesCondition de cond+matchesCondition de (And conds) = all (matchesCondition de) conds+matchesCondition de (Or conds) = any (matchesCondition de) conds+matchesCondition _ All = True+matchesCondition _ None = False++-- | Determine locale language settings+getPreferredLanguages :: IO [String]+getPreferredLanguages = do+ mLcMessages <- lookupEnv "LC_MESSAGES"+ lang <- case mLcMessages of+ Nothing -> lookupEnv "LANG" -- FIXME?+ Just lm -> return (Just lm)+ case lang of+ Nothing -> return []+ Just l -> return $+ let woEncoding = takeWhile (/= '.') l+ (language, _cm) = span (/= '_') woEncoding+ (country, _m) = span (/= '@') (if null _cm then "" else tail _cm)+ modifier = if null _m then "" else tail _m+ in dgl language country modifier+ where dgl "" "" "" = []+ dgl l "" "" = [l]+ dgl l c "" = [l ++ "_" ++ c, l]+ dgl l "" m = [l ++ "@" ++ m, l]+ dgl l c m = [l ++ "_" ++ c ++ "@" ++ m, l ++ "_" ++ c,+ l ++ "@" ++ m]++-- | Determine current Desktop+getXDGDesktop :: IO String+getXDGDesktop = do+ mCurDt <- lookupEnv "XDG_CURRENT_DESKTOP"+ return $ fromMaybe "???" mCurDt++-- | Return desktop directories+getDirectoryDirs :: IO [FilePath]+getDirectoryDirs = do+ dataDirs <- getXDGDataDirs+ existingDirs $ map (</> "desktop-directories") dataDirs++-- | Fetch menus and desktop entries and assemble the XDG menu.+readXDGMenu :: Maybe String -> IO (Maybe (XDGMenu, [DesktopEntry]))+readXDGMenu mMenuPrefix = do+ setLocaleEncoding utf8+ filenames <- getXDGMenuFilenames mMenuPrefix+ headMay . catMaybes <$> traverse maybeMenu filenames++-- | Load and assemble the XDG menu from a specific file, if it exists.+maybeMenu :: FilePath -> IO (Maybe (XDGMenu, [DesktopEntry]))+maybeMenu filename =+ ifM (doesFileExist filename)+ (do+ putStrLn $ "Reading " ++ filename+ contents <- readFile filename+ langs <- getPreferredLanguages+ runMaybeT $ do+ m <- MaybeT $ return $ parseXMLDoc contents >>= parseMenu+ des <- lift $ getApplicationEntries langs m+ return (m, des))+ (do+ putStrLn $ "Error: menu file '" ++ filename ++ "' does not exist!"+ return Nothing)
− src/System/Taffybar/LayoutSwitcher.hs
@@ -1,113 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}--------------------------------------------------------------------------------- |--- Module : System.Taffybar.LayoutSwitcher--- Copyright : (c) José A. Romero L.--- License : BSD3-style (see LICENSE)------ Maintainer : José A. Romero L. <escherdragon@gmail.com>--- Stability : unstable--- Portability : unportable------ Simple text widget that shows the XMonad layout used in the currently--- active workspace, and that allows to change it by clicking with the--- mouse: left-click to switch to the next layout in the list, right-click--- to switch to the first one (as configured in @xmonad.hs@)------ 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.LayoutSwitcher (- -- * Usage- -- $usage- layoutSwitcherNew-) where--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-import System.Taffybar.Widgets.Util---- $usage------ This widget requires that the "System.Taffybar.Hooks.PagerHints" hook be--- installed 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.LayoutSwitcher--- > main = do--- > pager <- pagerNew defaultPagerConfig--- > let los = layoutSwitcherNew pager------ now you can use @los@ as any other Taffybar widget.---- | Name of the X11 events to subscribe, and of the hint to look for for--- the name of the current layout.-xLayoutProp :: String-xLayoutProp = "_XMONAD_CURRENT_LAYOUT"---- | Create a new LayoutSwitcher widget that will use the given Pager as--- its source of events.-layoutSwitcherNew :: Pager -> IO Gtk.Widget-layoutSwitcherNew pager = do- label <- Gtk.labelNew (Nothing :: Maybe String)- -- 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- 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--- the PagerHints hook to notify of changes in the current layout.-pagerCallback :: PagerConfig -> Gtk.Label -> Event -> PagerIO ()-pagerCallback cfg label _ = do- layout <- liftPagerX11 $ readAsString Nothing xLayoutProp- markup <- lift $ activeLayoutIO cfg $ activeLayout cfg layout- lift $ Gtk.labelSetMarkup label markup---- | Build the graphical representation of the widget.-assembleWidget :: Pager -> Gtk.Label -> IO Gtk.Widget-assembleWidget pager label = do- ebox <- Gtk.eventBoxNew- Gtk.containerAdd ebox label- _ <- Gtk.on ebox Gtk.buttonPressEvent (dispatchButtonEvent pager)- Gtk.widgetShowAll ebox- return $ Gtk.toWidget ebox---- | Call 'switch' with the appropriate argument (1 for left click, -1 for--- right click), depending on the click event received.-dispatchButtonEvent :: Pager -> Gtk.EventM Gtk.EButton Bool-dispatchButtonEvent pager = do- btn <- Gtk.eventButton- let trigger = onClick [Gtk.SingleClick]- run = runWithPager pager- case btn of- Gtk.LeftButton -> trigger $ run $ switch 1- Gtk.RightButton -> trigger $ run $ switch (-1)- _ -> return False---- | Emit a new custom event of type _XMONAD_CURRENT_LAYOUT, that can be--- intercepted by the PagerHints hook, which in turn can instruct XMonad to--- switch to a different layout.-switch :: Int -> X11Property ()-switch n = do- cmd <- getAtom xLayoutProp- sendCommandEvent cmd (fromIntegral n)
− src/System/Taffybar/MPRIS.hs
@@ -1,109 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}--- | This is a "Now Playing"-style widget that listens for MPRIS--- events on DBus. Various media players implement this. This widget--- 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.-module System.Taffybar.MPRIS- ( TrackInfo (..)- , MPRISConfig (..)- , defaultMPRISConfig- , mprisNew- ) where--import Control.Monad ( void )-import Data.Int ( Int32 )-import qualified Data.Map as M-import Data.Text ( Text )-import qualified Data.Text as T-import DBus-import DBus.Client-import Graphics.UI.Gtk hiding ( Signal, Variant )-import Text.Printf----data TrackInfo = TrackInfo- { trackArtist :: Maybe String -- ^ Artist name, if available.- , trackTitle :: Maybe String -- ^ Track name, if available.- , 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"- , matchInterface = Just "org.freedesktop.MediaPlayer"- , matchMember = Just "TrackChange"- }- stateMatcher = matchAny { matchSender = Nothing- , matchDestination = Nothing- , matchPath = Just "/Player"- , matchInterface = Just "org.freedesktop.MediaPlayer"- , matchMember = Just "StatusChange"- }- client <- connectSession- void $ addMatch client trackMatcher (trackCallback cfg w)- void $ addMatch client stateMatcher (stateCallback w)--variantDictLookup :: (IsVariant b, Ord k) => k -> M.Map k Variant -> Maybe b-variantDictLookup k m = do- val <- M.lookup k m- fromVariant val---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 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.- labelSetMarkup w txt- widgetShowAll w- _ -> return ()--stateCallback :: Label -> Signal -> IO ()-stateCallback w s =- case fromVariant (signalBody s !! 0) of- Just st -> case structureItems st of- (pstate:_) -> case (fromVariant pstate) :: Maybe Int32 of- Just 2 -> postGUIAsync $ widgetHide w- Just 1 -> postGUIAsync $ widgetHide w- Just 0 -> postGUIAsync $ widgetShowAll w- _ -> return ()- _ -> return ()- _ -> return ()--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 cfg l- widgetShowAll l- return (toWidget l)
− src/System/Taffybar/MPRIS2.hs
@@ -1,127 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}--- | This is a "Now Playing"-style widget that listens for MPRIS--- events on DBus. Various media players implement this. This widget--- works with version 2 of the MPRIS protocol--- (http://www.mpris.org/2.0/spec.html).----module System.Taffybar.MPRIS2 ( mpris2New ) where--import Control.Monad ( void )-import Data.Maybe ( listToMaybe )-import DBus-import DBus.Client hiding (getProperty)-import Data.List (isPrefixOf)-import Graphics.UI.Gtk hiding ( Signal, Variant )-import Text.Printf--mpris2New :: IO Widget-mpris2New = do- label <- labelNew (Nothing :: Maybe String)- widgetHide label- _ <- on label realize $ initLabel label- return (toWidget label)--unpack :: IsVariant a => Variant -> a-unpack var = case fromVariant var of- Just x -> x- Nothing -> error("Could not unpack variant: " ++ show var)--initLabel :: Label -> IO ()-initLabel w = do- client <- connectSession- -- Set initial song state/info- reqSongInfo w client- void $ addMatch client propMatcher (callBack w)- return ()- where callBack label s = do- let items = dictionaryItems $ unpack (signalBody s !! 1)- updatePlaybackStatus label items- updateMetadata label items- return ()- propMatcher = matchAny { matchSender = Nothing- , matchDestination = Nothing- , matchPath = Just "/org/mpris/MediaPlayer2"- , matchInterface = Just "org.freedesktop.DBus.Properties"- , matchMember = Just "PropertiesChanged"- }--reqSongInfo :: Label -> Client -> IO ()-reqSongInfo w client = do- rep <- call_ client (methodCall "/org/freedesktop/DBus" "org.freedesktop.DBus" "ListNames")- { methodCallDestination = Just "org.freedesktop.DBus" }- let plist = unpack $ methodReturnBody rep !! 0- let players = filter (isPrefixOf "org.mpris.MediaPlayer2.") plist- case length players of- 0 -> return ()- _ -> do- reply <- getProperty client (players !! 0) "Metadata"- updateSongInfo w $ dictionaryItems $ (unpack . unpack) (methodReturnBody reply !! 0)- reply' <- getProperty client (players !! 0) "PlaybackStatus"- let status = (unpack . unpack) (methodReturnBody reply' !! 0) :: String- case status of- "Playing" -> postGUIAsync $ widgetShow w- "Paused" -> postGUIAsync $ widgetHide w- "Stopped" -> postGUIAsync $ widgetHide w- _ -> return ()--getProperty :: Client -> String -> String -> IO MethodReturn-getProperty client name property = do- call_ client (methodCall "/org/mpris/MediaPlayer2" "org.freedesktop.DBus.Properties" "Get")- { methodCallDestination = Just (busName_ name)- , methodCallBody = [ toVariant ("org.mpris.MediaPlayer2.Player" :: String),- toVariant property ]- }--setSongInfo :: Label -> String -> String -> IO ()-setSongInfo w artist title = do- let msg :: String- 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--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- Just a -> do- case (unpack . unpack) a :: String of- "Playing" -> postGUIAsync $ widgetShow w- "Paused" -> postGUIAsync $ widgetHide w- "Stopped" -> postGUIAsync $ widgetHide w- _ -> return ()- Nothing -> do- return ()--updateSongInfo :: Label -> [(Variant, Variant)] -> IO ()-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- 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- case lookup (toVariant ("Metadata" :: String)) items of- Just meta -> do- let metaItems = dictionaryItems $ (unpack . unpack) meta- updateSongInfo w metaItems- Nothing -> return ()
− src/System/Taffybar/Menu/DesktopEntry.hs
@@ -1,179 +0,0 @@-{-# OPTIONS_HADDOCK hide #-}--------------------------------------------------------------------------------- |--- Module : System.Taffybar.Menu.DesktopEntry--- Copyright : 2017 Ulf Jasper--- License : BSD3-style (see LICENSE)------ Maintainer : Ulf Jasper <ulf.jasper@web.de>--- Stability : unstable--- Portability : unportable------ Implementation of version 1.1 of the freedesktop "Desktop Entry--- specification", see--- https://specifications.freedesktop.org/desktop-entry-spec/desktop-entry-spec-1.1.html.------ See also 'MenuWidget'.--------------------------------------------------------------------------------module System.Taffybar.Menu.DesktopEntry (- DesktopEntry(..),- listDesktopEntries,- getDirectoryEntry,- deHasCategory,- deName,- deOnlyShowIn,- deNotShowIn,- deComment,- deCommand,- deIcon,- deNoDisplay)--where--import Control.Monad.Except-import Data.Char-import qualified Data.ConfigFile as CF-import Data.List-import Data.Maybe-import System.Directory-import System.FilePath.Posix--data DesktopEntryType = Application | Link | Directory- deriving (Read, Show, Eq)---- | Desktop Entry. All attributes (key-value-pairs) are stored in an--- association list.-data DesktopEntry = DesktopEntry {- deType :: DesktopEntryType,- deFilename :: FilePath, -- ^ unqualified filename, e.g. "taffybar.desktop"- deAttributes :: [(String, String)], -- ^ Key-value pairs- deAllocated :: Bool -- ^ already contained in some menu?- }- deriving (Read, Show, Eq)---- | Determine whether the Category attribute of a desktop entry--- contains a given value.-deHasCategory :: DesktopEntry -- ^ desktop entry- -> String -- ^ category to be checked- -> Bool-deHasCategory de cat = case lookup "Categories" (deAttributes de) of- Nothing -> False- Just cats -> cat `elem` splitAtSemicolon cats--splitAtSemicolon :: String -> [String]-splitAtSemicolon = lines . (map (\c -> if c == ';' then '\n' else c))---- | Return the proper name of the desktop entry, depending on the--- list of preferred languages.-deName :: [String] -- ^ Preferred languages- -> DesktopEntry- -> String-deName langs de = fromMaybe (deFilename de) $ deLocalisedAtt langs de "Name" ---- | Return the categories in which the entry shall be shown-deOnlyShowIn :: DesktopEntry -> [String]-deOnlyShowIn = maybe [] (splitAtSemicolon) . deAtt "OnlyShowIn" ---- | Return the categories in which the entry shall not be shown-deNotShowIn :: DesktopEntry -> [String]-deNotShowIn = maybe [] (splitAtSemicolon) . deAtt "NotShowIn" ---- | Return the value of the given attribute key-deAtt :: String -> DesktopEntry -> Maybe String-deAtt att = lookup att . deAttributes---- | Return the Icon attribute-deIcon :: DesktopEntry -> Maybe String-deIcon = deAtt "Icon"---- | Return True if the entry must not be displayed-deNoDisplay :: DesktopEntry -> Bool-deNoDisplay de = maybe False (("true" ==) . (map toLower)) $ deAtt "NoDisplay" de--deLocalisedAtt :: [String] -- ^ Preferred languages- -> DesktopEntry- -> String- -> Maybe String-deLocalisedAtt langs de att = - let localeMatches = catMaybes $ map (\l -> lookup (att ++ "[" ++ l ++ "]") (deAttributes de)) langs- in if null localeMatches- then lookup att $ deAttributes de- else Just $ head localeMatches---- | Return the proper comment of the desktop entry, depending on the--- list of preferred languages.-deComment :: [String] -- ^ Preferred languages- -> DesktopEntry- -> Maybe String-deComment langs de = deLocalisedAtt langs de "Comment"---- | Return the command defined by the given desktop entry. FIXME:--- should check the dbus thing. FIXME: are there "field codes",--- i.e. %<char> things, that should be respected?-deCommand :: DesktopEntry -> Maybe String-deCommand de = - case lookup "Exec" (deAttributes de) of- Nothing -> Nothing- Just cmd -> Just $ reverse $ dropWhile (== ' ') $ reverse $ takeWhile (/= '%') cmd---- | Return a list of all desktop entries in the given directory.-listDesktopEntries :: String -> FilePath -> IO [DesktopEntry]-listDesktopEntries extension dir = do- let ndir = normalise dir- putStrLn $ "Listing desktop entries in " ++ ndir- ex <- doesDirectoryExist ndir- if ex- then do files <- mapM (return . (ndir </>))- =<< return . filter (/= ".")- =<< return . filter (/= "..")- =<< getDirectoryContents dir- mEntries <- mapM (readDesktopEntry) $ filter (extension `isSuffixOf`) files- let entries = nub $ catMaybes mEntries- subDirs <- filterM doesDirectoryExist files- subEntries <- return . concat =<< mapM (listDesktopEntries extension) subDirs - return $ entries ++ subEntries- else do putStrLn $ "Does not exist: " ++ ndir- return []---- | Return a list of all desktop entries in the given directory.-getDirectoryEntry :: String -> [FilePath] -> IO (Maybe DesktopEntry)-getDirectoryEntry name dirs = do- exFiles <- filterM doesFileExist $ map ((</> name) . normalise) dirs- if null exFiles- then return Nothing- else readDesktopEntry $ head exFiles---- | Main section of a desktop entry file.-sectionMain :: String-sectionMain = "Desktop Entry"---- | Read a desktop entry from a file.-readDesktopEntry :: FilePath -> IO (Maybe DesktopEntry)-readDesktopEntry fp = do- ex <- doesFileExist fp- if ex- then doReadDesktopEntry fp- else do putStrLn $ "File does not exist: '" ++ fp ++ "'"- return Nothing-- where doReadDesktopEntry :: FilePath -> IO (Maybe DesktopEntry)- doReadDesktopEntry f = do- eResult <- runExceptT $ do- cp <- join $ liftIO $ CF.readfile CF.emptyCP f- items <- CF.items cp sectionMain- return items-- case eResult of- Left _ -> return Nothing- Right r -> return $ Just $ DesktopEntry- {deType = maybe Application read (lookup "Type" r),- deFilename = f,- deAttributes = r,- deAllocated = False}---- -- | Test--- testDesktopEntry :: IO ()--- testDesktopEntry = do--- print =<< readDesktopEntry "/usr/share/applications/taffybar.desktop"-
− src/System/Taffybar/Menu/Menu.hs
@@ -1,124 +0,0 @@-{-# OPTIONS_HADDOCK hide #-}--------------------------------------------------------------------------------- |--- Module : System.Taffybar.Menu.Menu--- Copyright : 2017 Ulf Jasper--- License : BSD3-style (see LICENSE)------ Maintainer : Ulf Jasper <ulf.jasper@web.de>--- Stability : unstable--- Portability : unportable------ Implementation of version 1.1 of the freedesktop "Desktop Menu--- Specification", see--- https://specifications.freedesktop.org/menu-spec/menu-spec-1.1.html------ See also 'MenuWidget'.--------------------------------------------------------------------------------module System.Taffybar.Menu.Menu (- Menu(..),- MenuEntry(..),- buildMenu,- getApplicationEntries)-where--import Data.Char (toLower)-import Data.List-import Data.Maybe-import System.Taffybar.Menu.DesktopEntry-import System.Taffybar.Menu.XdgMenu---- | Displayable menu-data Menu = Menu {- fmName :: String,- fmComment :: String,- fmIcon :: Maybe String,- fmSubmenus :: [Menu],- fmEntries :: [MenuEntry],- fmOnlyUnallocated :: Bool}- deriving (Show)---- | Displayable menu entry-data MenuEntry = MenuEntry {- feName :: String,- feComment :: String,- feCommand :: String,- feIcon :: Maybe String}- deriving (Eq, Show)----- | Fetch menus and desktop entries and assemble the menu.-buildMenu :: Maybe String -> IO Menu-buildMenu mMenuPrefix = do- mMenuDes <- readXdgMenu mMenuPrefix- case mMenuDes of- Nothing -> return $ Menu "???" "Parsing failed" Nothing [] [] False- Just (menu, des) -> do dt <- getXdgDesktop- dirDirs <- getDirectoryDirs- langs <- getPreferredLanguages- (fm, ae) <- xdgToMenu dt langs dirDirs des menu- let fm' = fixOnlyUnallocated ae fm- return fm'---- | Convert xdg menu to displayable menu-xdgToMenu :: String -> [String] -> [FilePath] -> [DesktopEntry] -> XdgMenu- -> IO (Menu, [MenuEntry])-xdgToMenu desktop langs dirDirs des xm = do- dirEntry <- getDirectoryEntry (xmDirectory xm) dirDirs- mas <- mapM (xdgToMenu desktop langs dirDirs des) (xmSubmenus xm)- let (menus, subaes) = unzip mas- menus' = sortBy (\fm1 fm2 -> compare (map toLower $ fmName fm1)- (map toLower $ fmName fm2)) menus- entries = map (xdgToMenuEntry langs) $- -- hide NoDisplay- filter (not . deNoDisplay) $- -- onlyshowin- filter (matchesOnlyShowIn desktop) $- -- excludes- filter (not . flip matchesCondition (fromMaybe None (xmExclude xm))) $- -- includes- filter (flip matchesCondition (fromMaybe None (xmInclude xm))) des- onlyUnallocated = xmOnlyUnallocated xm- aes = if onlyUnallocated then [] else entries ++ concat subaes- let fm = Menu {fmName = maybe (xmName xm) (deName langs) dirEntry,- fmComment = maybe "???" (fromMaybe "???" . deComment langs) dirEntry,- fmIcon = deIcon =<< dirEntry,- fmSubmenus = menus',- fmEntries = entries,- fmOnlyUnallocated = onlyUnallocated}- return (fm, aes)---- | Check the "only show in" logic-matchesOnlyShowIn :: String -> DesktopEntry -> Bool-matchesOnlyShowIn desktop de = matchesShowIn && notMatchesNotShowIn- where matchesShowIn = case deOnlyShowIn de of- [] -> True- desktops -> desktop `elem` desktops- notMatchesNotShowIn = case deNotShowIn de of- [] -> True- desktops -> not $ desktop `elem` desktops---- | convert xdg desktop entry to displayble menu entry-xdgToMenuEntry :: [String] -> DesktopEntry -> MenuEntry-xdgToMenuEntry langs de = MenuEntry {feName = name,- feComment = comment,- feCommand = cmd,- feIcon = mIcon}- where mc = case deCommand de of- Nothing -> Nothing- Just c -> Just $ "(" ++ c ++ ")"- comment = fromMaybe "??" $ case deComment langs de of- Nothing -> mc- Just tt -> Just $ tt ++ maybe "" ("\n" ++) mc- cmd = fromMaybe "FIXME" $ deCommand de- name = deName langs de- mIcon = deIcon de---- | postprocess unallocated entries-fixOnlyUnallocated :: [MenuEntry] -> Menu -> Menu-fixOnlyUnallocated fes fm = fm {fmEntries = entries,- fmSubmenus = map (fixOnlyUnallocated fes) (fmSubmenus fm)}- where entries = if (fmOnlyUnallocated fm)- then filter (not . (`elem` fes)) (fmEntries fm)- else fmEntries fm
− src/System/Taffybar/Menu/MenuWidget.hs
@@ -1,129 +0,0 @@--------------------------------------------------------------------------------- |--- Module : System.Taffybar.Menu.MenuWidget--- Copyright : 2017 Ulf Jasper--- License : BSD3-style (see LICENSE)------ Maintainer : Ulf Jasper <ulf.jasper@web.de>--- Stability : unstable--- Portability : unportable------ MenuWidget provides a hierachical GTK menu containing all--- applicable desktop entries found on the system. The menu is built--- according to the version 1.1 of the XDG "Desktop Menu--- Specification", see--- https://specifications.freedesktop.org/menu-spec/menu-spec-1.1.html--------------------------------------------------------------------------------module System.Taffybar.Menu.MenuWidget (- -- * Usage- -- $usage- menuWidgetNew)-where--import Control.Monad-import Graphics.UI.Gtk hiding (Menu)-import System.Directory-import System.FilePath.Posix-import System.Process-import System.Taffybar.Menu.Menu---- $usage------ In order to use this widget add the following line to your--- @taffybar.hs@ file:------ > import System.Taffybar.Menu.MenuWidget--- > main = do--- > let menu = menuWidgetNew $ Just "PREFIX-"------ The menu will look for a file named "PREFIX-applications.menu" in--- the (subdirectory "menus" of the) directories specified by the--- environment variable XDG_CONFIG_DIRS and "/etc/xdg". If no prefix--- is given (i.e. if you pass Nothing) then the value of the--- environment variable XDG_MENU_PREFIX is used, if it is set. If--- taffybar is running inside a desktop environment like Mate, Gnome,--- XFCE etc. the environment variables XDG_CONFIG_DIRS and--- XDG_MENU_PREFIX should be set and you may create the menu like this:------ > let menu = menuWidgetNew Nothing------ Now you can use @menu@ as any other Taffybar widget.----- | Add a desktop entry to a gtk menu by appending a gtk menu item.-addItem :: (MenuShellClass msc) =>- msc -- ^ GTK menu- -> MenuEntry -- ^ Desktop entry- -> IO ()-addItem ms de = do- item <- imageMenuItemNewWithLabel (feName de)- set item [ widgetTooltipText := Just (feComment de)]- setIcon item (feIcon de)- menuShellAppend ms item- _ <- on item menuItemActivated $ do- let cmd = feCommand de- putStrLn $ "Launching '" ++ cmd ++ "'"- _ <- spawnCommand cmd- return ()- return ()---- | Add an xdg menu to a gtk menu by appending gtk menu items and--- submenus.-addMenu :: (MenuShellClass msc) =>- msc -- ^ GTK menu- -> Menu -- ^ menu- -> IO ()-addMenu ms fm = do- let subMenus = fmSubmenus fm- items = fmEntries fm- when (not (null items) || not (null subMenus)) $ do- item <- imageMenuItemNewWithLabel (fmName fm)- setIcon item (fmIcon fm)- menuShellAppend ms item- subMenu <- menuNew- menuItemSetSubmenu item subMenu- mapM_ (addMenu subMenu) subMenus- mapM_ (addItem subMenu) $ items--setIcon :: ImageMenuItem -> Maybe String -> IO ()-setIcon _ Nothing = return ()-setIcon item (Just iconName) = do- iconTheme <- iconThemeGetDefault- hasIcon <- iconThemeHasIcon iconTheme iconName- mImg <- if hasIcon- then return . Just =<< imageNewFromIconName iconName IconSizeMenu- else if isAbsolute iconName- then do ex <- doesFileExist iconName- if ex- then do let defaultSize = 24 -- FIXME should auto-adjust to font size- pb <- pixbufNewFromFileAtScale iconName- defaultSize defaultSize True- return . Just =<< imageNewFromPixbuf pb- else return Nothing- else return Nothing- case mImg of- Just img -> imageMenuItemSetImage item img- Nothing -> putStrLn $ "Icon not found: " ++ iconName----- | Create a new XDG Menu Widget.-menuWidgetNew :: Maybe String -- ^ menu name, must end with a dash,- -- e.g. "mate-" or "gnome-"- -> IO Widget-menuWidgetNew mMenuPrefix = do- mb <- menuBarNew- m <- buildMenu mMenuPrefix- addMenu mb m- widgetShowAll mb- return (toWidget mb)---- -- | Show Xdg Menu Widget in a standalone frame.--- testMenuWidget :: IO ()--- testMenuWidget = do--- _ <- initGUI--- window <- windowNew--- _ <- window `on` deleteEvent $ liftIO mainQuit >> return False--- containerAdd window =<< menuWidgetNew Nothing--- widgetShowAll window--- mainGUI
− src/System/Taffybar/Menu/XdgMenu.hs
@@ -1,277 +0,0 @@-{-# OPTIONS_HADDOCK hide #-}--------------------------------------------------------------------------------- |--- Module : System.Taffybar.Menu.XdgMenu--- Copyright : 2017 Ulf Jasper--- License : BSD3-style (see LICENSE)------ Maintainer : Ulf Jasper <ulf.jasper@web.de>--- Stability : unstable--- Portability : unportable------ Implementation of version 1.1 of the XDG "Desktop Menu--- Specification", see--- https://specifications.freedesktop.org/menu-spec/menu-spec-1.1.html----- specification, see--- See also 'MenuWidget'.----------------------------------------------------------------------------------module System.Taffybar.Menu.XdgMenu (- XdgMenu(..),- DesktopEntryCondition(..),- readXdgMenu,- matchesCondition,- getXdgDesktop,- getDirectoryDirs,- getApplicationEntries,- getPreferredLanguages)-where--import Control.Applicative-import Control.Monad.Trans-import Control.Monad.Trans.Maybe-import Data.Char (toLower)-import Data.List-import Data.Maybe-import qualified Data.Set as S-import qualified Debug.Trace as D-import GHC.IO.Encoding-import Prelude-import Safe (headMay)-import System.Directory-import System.Environment-import System.FilePath.Posix-import System.Posix.Files-import System.Taffybar.Menu.DesktopEntry-import System.Taffybar.Util-import Text.XML.Light-import Text.XML.Light.Helpers---- Environment Variables---- | Produce a list of config locations to search, starting with--- XDG_CONFIG_HOME and XDG_CONFIG_DIRS, with fallback to /etc/xdg-getXdgConfigDirs :: IO [String]-getXdgConfigDirs = do- ch <- lookupEnv "XDG_CONFIG_HOME"- cd <- lookupEnv "XDG_CONFIG_DIRS"- let dirs = catMaybes [ch]- ++ maybe [] splitSearchPath cd- exDirs <- existingDirs dirs- return $ if null exDirs- then ["/etc/xdg/"]- else map normalise exDirs--existingDirs :: [FilePath] -> IO [FilePath]-existingDirs dirs = do- exs <- mapM fileExist dirs- return $ S.toList $ S.fromList $ map fst $ filter snd $ zip dirs exs--getXdgMenuPrefix :: IO (Maybe String)-getXdgMenuPrefix = lookupEnv "XDG_MENU_PREFIX"--getXdgDataDirs :: IO [String]-getXdgDataDirs = do- mDh <- lookupEnv "XDG_DATA_HOME"- dh <- case mDh of- Nothing -> do h <- getHomeDirectory- return $ h </> ".local" </> "share"- Just d -> return d- mPf <- lookupEnv "XDG_DATA_DIRS"- let dirs = maybe [] (map normalise . splitSearchPath) mPf- ++ ["/usr/local/share", "/usr/share"]- nubBy equalFilePath <$> existingDirs (dh:dirs)---- | Find filename(s) of the application menu(s).-getXdgMenuFilenames :: Maybe String- -- ^ Overrides the value of the environment variable XDG_MENU_PREFIX.- -- Specifies the prefix for the menu (e.g. 'Just "mate-"'). FIXME- -> IO [FilePath]-getXdgMenuFilenames mMenuPrefix = do- configDirs <- getXdgConfigDirs- maybePrefix <- (mMenuPrefix <|>) <$> getXdgMenuPrefix- let maybeAddDash t = if last t == '-' then t else t ++ "-"- dashedPrefix = maybe "" maybeAddDash maybePrefix- return $ map (</> "menus" </> dashedPrefix ++ "applications.menu") configDirs---- | XDG Menu, cf. "Desktop Menu Specification".-data XdgMenu = XdgMenu {- xmAppDir :: Maybe String,- xmDefaultAppDirs :: Bool, -- Use $XDG_DATA_DIRS/applications- xmDirectoryDir :: Maybe String,- xmDefaultDirectoryDirs :: Bool, -- Use $XDG_DATA_DIRS/desktop-directories- xmLegacyDirs :: [String],- xmName :: String,- xmDirectory :: String,- xmOnlyUnallocated :: Bool,- xmDeleted :: Bool,- xmInclude :: Maybe DesktopEntryCondition,- xmExclude :: Maybe DesktopEntryCondition,- xmSubmenus :: [XdgMenu],- xmLayout :: [XdgLayoutItem]}- deriving(Show)--data XdgLayoutItem =- XliFile String | XliSeparator | XliMenu String | XliMerge String- deriving(Show)---- | Return a list of all available desktop entries for a given xdg menu.-getApplicationEntries :: [String] -- ^ Preferred languages- -> XdgMenu- -> IO [DesktopEntry]-getApplicationEntries langs xm = do- defEntries <- if xmDefaultAppDirs xm- then do dataDirs <- getXdgDataDirs- putStrLn $ "DataDirs=" ++ show dataDirs- concat <$> mapM (listDesktopEntries ".desktop" .- (</> "applications")) dataDirs- else return []- return $ sortBy (\de1 de2 -> compare (map toLower (deName langs de1))- (map toLower (deName langs de2))) defEntries---- | Parse menu.-parseMenu :: Element -> Maybe XdgMenu-parseMenu elt =- let appDir = getChildData "AppDir" elt- defaultAppDirs = case getChildData "DefaultAppDirs" elt of- Nothing -> False- Just _ -> True- directoryDir = getChildData "DirectoryDir" elt- defaultDirectoryDirs = case getChildData "DefaultDirectoryDirs" elt of- Nothing -> False- Just _ -> True- name = fromMaybe "Name?" $ getChildData "Name" elt- dir = fromMaybe "Dir?" $ getChildData "Directory" elt- onlyUnallocated = case (getChildData "OnlyUnallocated" elt,- getChildData "NotOnlyUnallocated" elt) of- (Nothing, Nothing) -> False -- ?!- (Nothing, Just _) -> False- (Just _, Nothing) -> True- (Just _, Just _) -> False -- ?!- deleted = False -- FIXME- include = parseConditions "Include" elt- exclude = parseConditions "Exclude" elt- layout = parseLayout elt- subMenus = fromMaybe [] $ mapChildren "Menu" elt parseMenu- in Just XdgMenu {xmAppDir = appDir,- xmDefaultAppDirs = defaultAppDirs,- xmDirectoryDir = directoryDir,- xmDefaultDirectoryDirs = defaultDirectoryDirs,- xmLegacyDirs = [],- xmName = name,- xmDirectory = dir,- xmOnlyUnallocated = onlyUnallocated,- xmDeleted = deleted,- xmInclude = include,- xmExclude = exclude,- xmSubmenus = subMenus,- xmLayout = layout} -- FIXME---- | Parse Desktop Entry conditions for Include/Exclude clauses.-parseConditions :: String -> Element -> Maybe DesktopEntryCondition-parseConditions key elt = case findChild (unqual key) elt of- Nothing -> Nothing- Just inc -> doParseConditions (elChildren inc)- where doParseConditions :: [Element] -> Maybe DesktopEntryCondition- doParseConditions [] = Nothing- doParseConditions [e] = parseSingleItem e- doParseConditions elts = Just $ Or $ mapMaybe parseSingleItem elts-- parseSingleItem e = case qName (elName e) of- "Category" -> Just $ Category $ strContent e- "Filename" -> Just $ Filename $ strContent e- "And" -> Just $ And $ mapMaybe parseSingleItem- $ elChildren e- "Or" -> Just $ Or $ mapMaybe parseSingleItem- $ elChildren e- "Not" -> case parseSingleItem (head (elChildren e)) of- Nothing -> Nothing- Just rule -> Just $ Not rule- unknown -> D.trace ("Unknown Condition item: " ++ unknown) Nothing---- | Combinable conditions for Include and Exclude statements.-data DesktopEntryCondition = Category String- | Filename String- | Not DesktopEntryCondition- | And [DesktopEntryCondition]- | Or [DesktopEntryCondition]- | All- | None- deriving (Read, Show, Eq)--parseLayout :: Element -> [XdgLayoutItem]-parseLayout elt = case findChild (unqual "Layout") elt of- Nothing -> []- Just lt -> mapMaybe parseLayoutItem (elChildren lt)- where parseLayoutItem :: Element -> Maybe XdgLayoutItem- parseLayoutItem e = case qName (elName e) of- "Separator" -> Just XliSeparator- "Filename" -> Just $ XliFile $ strContent e- unknown -> D.trace ("Unknown layout item: " ++ unknown) Nothing---- | Determine whether a desktop entry fulfils a condition.-matchesCondition :: DesktopEntry -> DesktopEntryCondition -> Bool-matchesCondition de (Category cat) = deHasCategory de cat-matchesCondition de (Filename fn) = fn == deFilename de-matchesCondition de (Not cond) = not $ matchesCondition de cond-matchesCondition de (And conds) = all (matchesCondition de) conds-matchesCondition de (Or conds) = any (matchesCondition de) conds-matchesCondition _ All = True-matchesCondition _ None = False---- | Determine locale language settings-getPreferredLanguages :: IO [String]-getPreferredLanguages = do- mLcMessages <- lookupEnv "LC_MESSAGES"- lang <- case mLcMessages of- Nothing -> lookupEnv "LANG" -- FIXME?- Just lm -> return (Just lm)- case lang of- Nothing -> return []- Just l -> return $- let woEncoding = takeWhile (/= '.') l- (language, _cm) = span (/= '_') woEncoding- (country, _m) = span (/= '@') (if null _cm then "" else tail _cm)- modifier = if null _m then "" else tail _m- in dgl language country modifier- where dgl "" "" "" = []- dgl l "" "" = [l]- dgl l c "" = [l ++ "_" ++ c, l]- dgl l "" m = [l ++ "@" ++ m, l]- dgl l c m = [l ++ "_" ++ c ++ "@" ++ m, l ++ "_" ++ c,- l ++ "@" ++ m]---- | Determine current Desktop-getXdgDesktop :: IO String-getXdgDesktop = do- mCurDt <- lookupEnv "XDG_CURRENT_DESKTOP"- return $ fromMaybe "???" mCurDt---- | Return desktop directories-getDirectoryDirs :: IO [FilePath]-getDirectoryDirs = do- dataDirs <- getXdgDataDirs- existingDirs $ map (</> "desktop-directories") dataDirs---- | Fetch menus and desktop entries and assemble the XDG menu.-readXdgMenu :: Maybe String -> IO (Maybe (XdgMenu, [DesktopEntry]))-readXdgMenu mMenuPrefix = do- setLocaleEncoding utf8- filenames <- getXdgMenuFilenames mMenuPrefix- headMay . catMaybes <$> traverse maybeMenu filenames---- | Load and assemble the XDG menu from a specific file, if it exists.-maybeMenu :: FilePath -> IO (Maybe (XdgMenu, [DesktopEntry]))-maybeMenu filename =- ifM (doesFileExist filename)- (do- putStrLn $ "Reading " ++ filename- contents <- readFile filename- langs <- getPreferredLanguages- runMaybeT $ do- m <- MaybeT $ return $ parseXMLDoc contents >>= parseMenu- des <- lift $ getApplicationEntries langs m- return (m, des))- (do- putStrLn $ "Error: menu file '" ++ filename ++ "' does not exist!"- return Nothing)
− src/System/Taffybar/NetMonitor.hs
@@ -1,138 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TupleSections #-}--------------------------------------------------------------------------------- |--- Module : System.Taffybar.NetMonitor--- Copyright : (c) José A. Romero L.--- License : BSD3-style (see LICENSE)------ Maintainer : José A. Romero L. <escherdragon@gmail.com>--- Stability : unstable--- Portability : unportable------ Simple text widget that displays incoming\/outgoing network traffic over--- one selected interface, as provided by the "System.Information.Network"--- module.-----------------------------------------------------------------------------------module System.Taffybar.NetMonitor (- netMonitorNew,- netMonitorNewWith,- netMonitorMultiNew,- netMonitorMultiNewWith,- defaultNetFormat- ) where--import Data.IORef-import Graphics.UI.Gtk-import System.Information.Network (getNetInfo)-import System.Taffybar.Widgets.PollingLabel-import Text.Printf (printf)-import Text.StringTemplate-import Data.Maybe (catMaybes)-import qualified Data.Traversable as T--defaultNetFormat :: String-defaultNetFormat = "▼ $inAuto$ ▲ $outAuto$"---- | Creates a new network monitor widget. It consists of two 'PollingLabel's,--- one for incoming and one for outgoing traffic fed by regular calls to--- 'getNetInfo'.-netMonitorNew :: Double -- ^ Polling interval (in seconds, e.g. 1.5)- -> String -- ^ Name of the network interface to monitor (e.g. \"eth0\", \"wlan1\")- -> IO Widget-netMonitorNew interval interface = netMonitorMultiNew interval [interface]---- | Creates a new network monitor widget with custom template and precision.--- Similar to 'netMonitorNew'.------ The format template currently supports four units: bytes,--- kilobytes, megabytes, and auto.-netMonitorNewWith :: Double -- ^ Polling interval (in seconds, e.g. 1.5)- -> String -- ^ Name of the network interface to monitor (e.g. \"eth0\", \"wlan1\")- -> Int -- ^ Precision for an output- -> String -- ^ Template for an output. You can use variables: $inB$, $inKB$, $inMB$, $inAuto$, $outB$, $outKB$, $outMB$, $outAuto$- -> IO Widget-netMonitorNewWith interval interface prec template = netMonitorMultiNewWith interval [interface] prec template---- | Like `netMonitorNew` but allows specification of multiple interfaces.--- Interfaces are allowed to not exist at all (e.g. unplugged usb ethernet),--- the resulting speed is the speed of all available interfaces summed up. So--- you get your network speed regardless of which interface you are currently--- using.-netMonitorMultiNew :: Double -- ^ Polling interval (in seconds, e.g. 1.5)- -> [String] -- ^ Name of the network interfaces to monitor (e.g. \"eth0\", \"wlan1\")- -> IO Widget-netMonitorMultiNew interval interfaces = netMonitorMultiNewWith interval interfaces 3 defaultNetFormat---- | Like `newMonitorNewWith` but for multiple interfaces.-netMonitorMultiNewWith :: Double -- ^ Polling interval (in seconds, e.g. 1.5)- -> [String] -- ^ Name of the network interfaces to monitor (e.g. \"eth0\", \"wlan1\")- -> Int -- ^ Precision for an output- -> String -- ^ Template for an output. You can use variables: $inB$, $inKB$, $inMB$, $inAuto$, $outB$, $outKB$, $outMB$, $outAuto$- -> IO Widget-netMonitorMultiNewWith interval interfaces prec template = do- interfaceRefs <- T.forM interfaces $ \i -> (i,) <$> newIORef (0, 0)- let showResult = showInfo template prec <$> calculateNetUse interfaceRefs- label <- pollingLabelNew "" interval showResult- widgetShowAll label- return (toWidget label)- where- calculateNetUse ifaceRefs = do- mIfaceInfos <- T.forM ifaceRefs $ \(i, ref) -> do- mIfaceInfo <- getNetInfo i- return $ fmap (\ifaceInfo -> (ref, ifaceInfo)) mIfaceInfo- speeds <- T.forM (catMaybes mIfaceInfos) $ \(ref, ifaceInfo) -> do- let ii = case ifaceInfo of- [info1, info2] -> (info1, info2)- _ -> (0, 0)- calcSpeed interval ref ii- return $ foldr (\(d, u) (dsum, usum) -> (dsum + d, usum + u)) (0, 0) speeds--calcSpeed :: Double -> IORef (Int, Int) -> (Int, Int) -> IO (Double, Double)-calcSpeed interval sample result@(r1, r2) = do- (s1, s2) <- readIORef sample- writeIORef sample result- return (max 0 (fromIntegral (r1 - s1) / interval), max 0 (fromIntegral (r2 - s2) / interval))--showInfo :: String -> Int -> (Double, Double) -> String-showInfo template prec (incomingb, outgoingb) =- let- attribs = [ ("inB", show incomingb)- , ("inKB", toKB prec incomingb)- , ("inMB", toMB prec incomingb)- , ("inAuto", toAuto prec incomingb)- , ("outB", show outgoingb)- , ("outKB", toKB prec outgoingb)- , ("outMB", toMB prec outgoingb)- , ("outAuto", toAuto prec outgoingb)- ]- in- render . setManyAttrib attribs $ newSTMP template--toKB :: Int -> Double -> String-toKB prec = setDigits prec . (/1024)--toMB :: Int -> Double -> String-toMB prec = setDigits prec . (/ (1024 * 1024))--setDigits :: Int -> Double -> String-setDigits dig a = printf format a- where format = "%." ++ show dig ++ "f"--toAuto :: Int -> Double -> String-toAuto prec value = printf "%.*f%s" p v unit- where value' = max 0 value- mag :: Int- mag = if value' == 0 then 0 else max 0 $ min 4 $ floor $ logBase 1024 value'- v = value' / 1024 ** fromIntegral mag- unit = case mag of- 0 -> "B/s"- 1 -> "KiB/s"- 2 -> "MiB/s"- 3 -> "GiB/s"- 4 -> "TiB/s"- _ -> "??B/s" -- unreachable- p :: Int- p = max 0 $ floor $ fromIntegral prec - logBase 10 v
− src/System/Taffybar/Pager.hs
@@ -1,200 +0,0 @@--------------------------------------------------------------------------------- |--- Module : System.Taffybar.Pager--- Copyright : (c) José A. Romero L.--- License : BSD3-style (see LICENSE)------ Maintainer : José A. Romero L. <escherdragon@gmail.com>--- Stability : unstable--- Portability : unportable------ Common support for pager widgets. This module does not provide itself--- any widgets, but implements an event dispatcher on which widgets can--- subscribe the desktop events they're interested in, as well as common--- configuration facilities.------ 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".------ You need only one Pager component to instantiate any number of pager--- widgets:------ > pager <- pagerNew defaultPagerConfig--- >--- > let wss = wspaceSwitcherNew pager -- Workspace Switcher widget--- > los = layoutSwitcherNew pager -- Layout Switcher widget--- > wnd = windowSwitcherNew pager -- Window Switcher widget-----------------------------------------------------------------------------------module System.Taffybar.Pager- ( Pager (..)- , PagerConfig (..)- , PagerIO- , defaultPagerConfig- , pagerNew- , subscribe- , colorize- , liftPagerX11- , liftPagerX11Def- , runWithPager- , shorten- , unsubscribe- , wrap- , escape- ) where--import qualified Control.Concurrent.MVar as MV-import Control.Monad.Reader-import Data.Unique-import System.Information.SafeX11-import qualified Data.Map as M-import Graphics.UI.Gtk (escapeMarkup)-import System.Information.EWMHDesktopInfo-import System.Information.X11DesktopInfo-import qualified System.Taffybar.Context as TContext-import Text.Printf (printf)---- | Structure contanining functions to customize the pretty printing of--- different widget elements.-data PagerConfig = PagerConfig- { activeWindow :: String -> String- -- ^ the name of the active window.- , activeLayout :: String -> String- -- ^ the currently active layout.- , activeLayoutIO :: String -> IO String- -- ^ IO action to modify active layout.- , activeWorkspace :: String -> String- -- ^ the currently active workspace.- , hiddenWorkspace :: String -> String- -- ^ inactive workspace with windows.- , emptyWorkspace :: String -> String- -- ^ inactive workspace with no windows.- , visibleWorkspace :: String -> String- -- ^ all other visible workspaces (Xinerama or XRandR).- , urgentWorkspace :: String -> String- -- ^ workspaces containing windows with the urgency hint set.- , widgetSep :: String- -- ^ separator to use between desktop widgets in 'TaffyPager'.- , workspaceBorder :: Bool- -- ^ wrap workspace buttons in a frame- , workspaceGap :: Int- -- ^ space in pixels between workspace buttons- , workspacePad :: Bool- -- ^ pad workspace name in button- , useImages :: Bool- -- ^ use images in the workspace switcher- , imageSize :: Int- -- ^ image height and width in pixels- , fillEmptyImages :: Bool- -- ^ fill empty images instead of clearing them- , customIcon :: Bool -> String -> String -> Maybe FilePath- -- ^ get custom icon based on: has-EWMH-icon, window-title, window-class- , windowSwitcherFormatter :: M.Map WorkspaceIdx String -> X11WindowHandle -> String- -- ^ title windows for WindowSwitcher- }---- | Structure containing the state of the Pager.-data Pager = Pager- { config :: PagerConfig -- ^ the configuration settings.- , tContext :: TContext.Context- }--type PagerIO a = ReaderT Pager IO a--liftPagerX11 :: X11Property a -> PagerIO a-liftPagerX11 prop = ask >>= lift . flip runWithPager prop--liftPagerX11Def :: a -> X11Property a -> PagerIO a-liftPagerX11Def def prop = liftPagerX11 $ postX11RequestSyncProp prop def--runWithPager :: Pager -> X11Property a -> IO a-runWithPager pager prop = do- x11Ctx <- MV.readMVar $ TContext.x11ContextVar $ tContext pager- runReaderT prop x11Ctx---- | Default pretty printing options.-defaultPagerConfig :: PagerConfig-defaultPagerConfig = PagerConfig- { activeWindow = escape . shorten 40- , activeLayout = escape- , activeLayoutIO = return- , activeWorkspace = colorize "yellow" "" . wrap "[" "]" . escape- , hiddenWorkspace = escape- , emptyWorkspace = const ""- , visibleWorkspace = wrap "(" ")" . escape- , urgentWorkspace = colorize "red" "yellow" . escape- , widgetSep = " : "- , workspaceBorder = False- , workspaceGap = 0- , workspacePad = True- , useImages = False- , imageSize = 16- , fillEmptyImages = False- , customIcon = \_ _ _ -> Nothing- , windowSwitcherFormatter = defaultFormatEntry- }---- | Build the name to display in the list of windows by prepending the name--- of the workspace it is currently in to the name of the window itself-defaultFormatEntry- :: M.Map WorkspaceIdx String -- ^ List $ names of all available workspaces- -> X11WindowHandle -- ^ Handle of the window to name- -> String-defaultFormatEntry wsNames ((ws, wtitle, _), _) =- printf "%s: %s " wsName $ nonEmpty wtitle- where- wsName = M.findWithDefault ("WS#" ++ show wsN) ws wsNames- WSIdx wsN = ws- nonEmpty x =- case x of- [] -> "(nameless window)"- _ -> x---- | Creates a new Pager component (wrapped in the IO Monad) that can be--- used by widgets for subscribing X11 events.-pagerNew :: PagerConfig -> IO Pager-pagerNew cfg = 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 -> (Event -> IO ()) -> String -> IO Unique-subscribe pager listener filterName =- runReaderT (TContext.subscribeToEvents [filterName] (lift . listener)) $- tContext pager--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.-colorize :: String -- ^ Foreground color.- -> String -- ^ Background color.- -> String -- ^ Contents.- -> String-colorize fg bg = printf "<span%s%s>%s</span>" (attr "fg" fg) (attr "bg" bg)- where attr name value- | null value = ""- | otherwise = printf " %scolor=\"%s\"" name value---- | Limit a string to a certain length, adding "..." if truncated.-shorten :: Int -> String -> String-shorten l s- | length s <= l = s- | l >= 3 = take (l - 3) s ++ "..."- | otherwise = "..."---- | Wrap the given string in the given delimiters.-wrap :: String -- ^ Left delimiter.- -> String -- ^ Right delimiter.- -> String -- ^ Output string.- -> String-wrap open close s = open ++ s ++ close---- | Escape strings so that they can be safely displayed by Pango in the--- bar widget-escape :: String -> String-escape = escapeMarkup
− src/System/Taffybar/PixbufCompat.hs
@@ -1,71 +0,0 @@-{-# 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
− src/System/Taffybar/SimpleClock.hs
@@ -1,119 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE ForeignFunctionInterface #-}--- | 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.SimpleClock (- textClockNew,- textClockNewWith,- defaultClockConfig,- ClockConfig(..)- ) where--import Control.Monad.Trans ( liftIO )-import Data.Time.Calendar ( toGregorian )-import qualified Data.Time.Clock as Clock-import Data.Time.Format-import Data.Time.LocalTime-import Graphics.UI.Gtk-import qualified Data.Time.Locale.Compat as L--import System.Taffybar.Widgets.PollingLabel-import System.Taffybar.Widgets.Util--makeCalendar :: IO TimeZone -> IO Window-makeCalendar tzfn = do- container <- windowNew- cal <- calendarNew- containerAdd container cal- -- update the date on show- _ <- on container showSignal $ resetCalendarDate cal tzfn- -- prevent calendar from being destroyed, it can be only hidden:- _ <- on container deleteEvent $ do- liftIO (widgetHide container)- return True- return container--resetCalendarDate :: Calendar -> IO TimeZone -> IO ()-resetCalendarDate cal tzfn = do- tz <- tzfn- current <- Clock.getCurrentTime- let (y,m,d) = toGregorian $ localDay $ utcToLocalTime tz current- calendarSelectMonth cal (fromIntegral m - 1) (fromIntegral y)- calendarSelectDay cal (fromIntegral d)--toggleCalendar :: WidgetClass w => w -> Window -> IO Bool-toggleCalendar w c = do- isVis <- get c widgetVisible- if isVis- then widgetHide c- else do- attachPopup w "Calendar" c- displayPopup w c- return True---- | 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 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 L.TimeLocale- }- 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- }--systemGetTZ :: IO TimeZone-systemGetTZ = setTZ >> getCurrentTimeZone---- | 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--foreign import ccall unsafe "time.h tzset"- c_tzset :: IO ()-#endif---- | A configurable text-based clock widget. It currently allows for--- a configurable time zone through the 'ClockConfig'.------ See also 'textClockNew'.-textClockNewWith :: ClockConfig -> String -> Double -> IO Widget-textClockNewWith cfg fmt updateSeconds = do- let ti = TimeInfo { getTZ = maybe systemGetTZ return userZone- , getLocale = maybe (return L.defaultTimeLocale) return userLocale- }- l <- pollingLabelNew "" updateSeconds (getCurrentTime' ti fmt)- ebox <- eventBoxNew- containerAdd ebox l- eventBoxSetVisibleWindow ebox False- cal <- makeCalendar $ getTZ ti- _ <- on ebox buttonPressEvent $ onClick [SingleClick] (toggleCalendar l cal)- widgetShowAll ebox- return (toWidget ebox)- where- userZone = clockTimeZone cfg- userLocale = clockTimeLocale cfg- -- alternate getCurrentTime that takes a specific TZ- getCurrentTime' :: TimeInfo -> String -> IO String- getCurrentTime' ti f = do- l <- getLocale ti- z <- getTZ ti- t <- Clock.getCurrentTime- return $ formatTime l f $ utcToZonedTime z t-
+ src/System/Taffybar/SimpleConfig.hs view
@@ -0,0 +1,149 @@+-----------------------------------------------------------------------------+-- |+-- Module : System.Taffybar.SimpleConfig+-- Copyright : (c) Ivan A. Malison+-- License : BSD3-style (see LICENSE)+--+-- Maintainer : Ivan A. Malison+-- Stability : unstable+-- Portability : unportable+-----------------------------------------------------------------------------+module System.Taffybar.SimpleConfig+ ( SimpleTaffyConfig(..)+ , Position(..)+ , defaultSimpleTaffyConfig+ , simpleTaffybar+ , toTaffyConfig+ , useAllMonitors+ , usePrimaryMonitor+ ) where++import qualified Control.Concurrent.MVar as MV+import Control.Monad.Trans+import Data.List+import Data.Maybe+import Data.Unique+import Graphics.UI.GIGtkStrut+import Graphics.UI.Gtk as Gtk+import System.Taffybar.Information.X11DesktopInfo+import System.Taffybar+import qualified System.Taffybar.Context as BC (BarConfig(..))+import System.Taffybar.Context hiding (BarConfig(..))+import System.Taffybar.Util++-- | The side of the monitor at which taffybar should be displayed.+data Position = Top | Bottom deriving (Show, Eq)++-- | A configuration object whose interface is simpler than that of+-- 'TaffybarConfig'. Unless you have a good reason to use taffybar's more+-- advanced interface, you should stick to this one.+data SimpleTaffyConfig = SimpleTaffyConfig+ {+ -- | The xinerama/xrandr monitor number to put the bar on (default: PrimaryMonitor)+ monitorsAction :: TaffyIO [Int]+ -- | Number of pixels to reserve for the bar+ , barHeight :: Int+ -- | Number of additional pixels to reserve for the bar strut (default: 0)+ , barPadding :: Int+ -- | The position of the bar on the screen (default: Top)+ , barPosition :: Position+ -- | The number of pixels between widgets+ , widgetSpacing :: Int+ -- | Widget constructors whose results 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+ , centerWidgets :: [TaffyIO Gtk.Widget]+ -- | Widget constructors whose results are placed at the end of the bar+ , endWidgets :: [TaffyIO Gtk.Widget]+ }++-- | Sensible defaults for most of the fields of 'SimpleTaffyConfig'. You'll+-- need to specify the widgets you want in the bar with 'startWidgets',+-- 'centerWidgets' and 'endWidgets'.+defaultSimpleTaffyConfig :: SimpleTaffyConfig+defaultSimpleTaffyConfig = SimpleTaffyConfig+ { monitorsAction = useAllMonitors+ , barHeight = 30+ , barPadding = 0+ , barPosition = Top+ , widgetSpacing = 5+ , startWidgets = []+ , centerWidgets = []+ , endWidgets = []+ }++toStrutConfig :: SimpleTaffyConfig -> Int -> StrutConfig+toStrutConfig SimpleTaffyConfig { barHeight = size+ , barPadding = padding+ , barPosition = pos+ } monitor =+ defaultStrutConfig+ { strutHeight = ExactSize $ fromIntegral size+ , strutYPadding = fromIntegral padding+ , strutXPadding = fromIntegral padding+ , strutAlignment = Center+ , strutMonitor = Just $ fromIntegral monitor+ , strutPosition =+ case pos of+ Top -> TopPos+ Bottom -> BottomPos+ }++toBarConfig :: SimpleTaffyConfig -> Int -> IO BC.BarConfig+toBarConfig config monitor = do+ let strutConfig = toStrutConfig config monitor+ barId <- newUnique+ return+ BC.BarConfig+ { BC.strutConfig = strutConfig+ , BC.widgetSpacing = fromIntegral $ widgetSpacing config+ , BC.startWidgets = startWidgets config+ , BC.centerWidgets = centerWidgets config+ , BC.endWidgets = endWidgets config+ , BC.barId = barId+ }++newtype SimpleBarConfigs = SimpleBarConfigs (MV.MVar [(Int, BC.BarConfig)])++toTaffyConfig :: SimpleTaffyConfig -> TaffybarConfig+toTaffyConfig conf = defaultTaffybarConfig { getBarConfigsParam = configGetter }+ where+ configGetter = do+ SimpleBarConfigs configsVar <-+ getStateDefault $ lift (SimpleBarConfigs <$> MV.newMVar [])+ monitorNumbers <- monitorsAction conf++ let lookupWithIndex barConfigs monitorNumber =+ (monitorNumber, lookup monitorNumber barConfigs)++ lookupAndUpdate barConfigs = do++ let (alreadyPresent, toCreate) =+ partition (isJust . snd) $+ map (lookupWithIndex barConfigs) monitorNumbers+ alreadyPresentConfigs = mapMaybe snd alreadyPresent++ newlyCreated <-+ mapM (forkM return (toBarConfig conf) . fst) toCreate+ let result = map snd newlyCreated ++ alreadyPresentConfigs+ return (barConfigs ++ newlyCreated, result)++ lift $ MV.modifyMVar configsVar lookupAndUpdate++-- | Start taffybar using 'SimpleTaffybarConfig'.+simpleTaffybar :: SimpleTaffyConfig -> IO ()+simpleTaffybar conf = dyreTaffybar $ toTaffyConfig conf++getMonitorCount :: IO Int+getMonitorCount = screenGetDefault >>= maybe (return 0) screenGetNMonitors++-- | Display a taffybar window on all monitors.+useAllMonitors :: TaffyIO [Int]+useAllMonitors = lift $ do+ count <- getMonitorCount+ return [0..count-1]++-- | Display the taffybar window on the primary monitor.+usePrimaryMonitor :: TaffyIO [Int]+usePrimaryMonitor =+ return . fromMaybe 0 <$> lift (withDefaultCtx getPrimaryOutputNumber)
− src/System/Taffybar/StrutProperties.hs
@@ -1,35 +0,0 @@-module System.Taffybar.StrutProperties ( setStrutProperties- , StrutProperties ) where--import Graphics.UI.Gtk--import Foreign-import Foreign.C.Types-import Unsafe.Coerce ( unsafeCoerce )--type StrutProperties = (Int, Int, Int, Int, Int, Int, Int, Int, Int, Int, Int, Int)--foreign import ccall "set_strut_properties"- c_set_strut_properties :: Ptr Window -> CLong -> CLong -> CLong -> CLong- -> CLong -> CLong- -> CLong -> CLong- -> CLong -> CLong- -> CLong -> CLong- -> ()---- | Reserve EWMH struts-setStrutProperties :: Window -> StrutProperties -> IO ()-setStrutProperties gtkWindow (left, right, top, bottom,- left_start_y, left_end_y,- right_start_y, right_end_y,- top_start_x, top_end_x,- bottom_start_x, bottom_end_x) = do- let ptrWin = unsafeCoerce gtkWindow :: ForeignPtr Window- let fi = fromIntegral- withForeignPtr ptrWin $ \realPointer -> do- return $ c_set_strut_properties realPointer (fi left) (fi right) (fi top) (fi bottom)- (fi left_start_y) (fi left_end_y)- (fi right_start_y) (fi right_end_y)- (fi top_start_x) (fi top_end_x)- (fi bottom_start_x) (fi bottom_end_x)-
+ src/System/Taffybar/Support/PagerHints.hs view
@@ -0,0 +1,115 @@+-----------------------------------------------------------------------------+-- |+-- Module : System.Taffybar.Hooks.PagerHints+-- Copyright : (c) José A. Romero L.+-- License : BSD3-style (see LICENSE)+--+-- Maintainer : José A. Romero L. <escherdragon@gmail.com>+-- Stability : unstable+-- Portability : unportable+--+-- Complements the "XMonad.Hooks.EwmhDesktops" with two additional hints+-- not contemplated by the EWMH standard:+--+-- [@_XMONAD_CURRENT_LAYOUT@] Contains a UTF-8 string with the name of the+-- windows layout currently used in the active workspace.+--+-- [@_XMONAD_VISIBLE_WORKSPACES@] Contains a list of UTF-8 strings with the+-- names of all the workspaces that are currently showed in a secondary+-- display, or an empty list if in the current installation there's only+-- one monitor.+--+-- The first hint can be set directly on the root window of the default+-- display, or indirectly via X11 events with an atom of the same+-- name. This allows both to track any changes that occur in the layout of+-- the current workspace, as well as to have it changed automatically by+-- just sending a custom event to the hook.+--+-- The second one should be considered read-only, and is set every time+-- XMonad calls its log hooks.+--+-----------------------------------------------------------------------------++module System.Taffybar.Support.PagerHints (+ -- * Usage+ -- $usage+ pagerHints+) where++import Codec.Binary.UTF8.String (encode)+import Control.Monad+import Data.Monoid+import Foreign.C.Types (CInt)+import XMonad+import qualified XMonad.StackSet as W++-- $usage+--+-- You can use this module with the following in your @xmonad.hs@ file:+--+-- > import System.Taffybar.Hooks.PagerHints (pagerHints)+-- >+-- > main = xmonad $ ewmh $ pagerHints $ defaultConfig+-- > ...++-- | The \"Current Layout\" custom hint.+xLayoutProp :: X Atom+xLayoutProp = getAtom "_XMONAD_CURRENT_LAYOUT"++-- | The \"Visible Workspaces\" custom hint.+xVisibleProp :: X Atom+xVisibleProp = getAtom "_XMONAD_VISIBLE_WORKSPACES"++-- | Add support for the \"Current Layout\" and \"Visible Workspaces\" custom+-- hints to the given config.+pagerHints :: XConfig a -> XConfig a+pagerHints c = c { handleEventHook = handleEventHook c +++ pagerHintsEventHook+ , logHook = logHook c +++ pagerHintsLogHook }+ where x +++ y = x `mappend` y++-- | Update the current values of both custom hints.+pagerHintsLogHook :: X ()+pagerHintsLogHook = do+ withWindowSet+ (setCurrentLayout . description . W.layout . W.workspace . W.current)+ withWindowSet+ (setVisibleWorkspaces . map (W.tag . W.workspace) . W.visible)++-- | Set the value of the \"Current Layout\" custom hint to the one given.+setCurrentLayout :: String -> X ()+setCurrentLayout l = withDisplay $ \dpy -> do+ r <- asks theRoot+ a <- xLayoutProp+ c <- getAtom "UTF8_STRING"+ let l' = map fromIntegral (encode l)+ io $ changeProperty8 dpy r a c propModeReplace l'++-- | Set the value of the \"Visible Workspaces\" hint to the one given.+setVisibleWorkspaces :: [String] -> X ()+setVisibleWorkspaces vis = withDisplay $ \dpy -> do+ r <- asks theRoot+ a <- xVisibleProp+ c <- getAtom "UTF8_STRING"+ let vis' = map fromIntegral $ concatMap ((++[0]) . encode) vis+ io $ changeProperty8 dpy r a c propModeReplace vis'++-- | Handle all \"Current Layout\" events received from pager widgets, and+-- set the current layout accordingly.+pagerHintsEventHook :: Event -> X All+pagerHintsEventHook ClientMessageEvent {+ ev_message_type = mt,+ ev_data = d+ } = withWindowSet $ \_ -> do+ a <- xLayoutProp+ when (mt == a) $ sendLayoutMessage d+ return (All True)+pagerHintsEventHook _ = return (All True)++-- | Request a change in the current layout by sending an internal message+-- to XMonad.+sendLayoutMessage :: [CInt] -> X ()+sendLayoutMessage evData = case evData of+ [] -> return ()+ x:_ -> if x < 0+ then sendMessage FirstLayout+ else sendMessage NextLayout
− src/System/Taffybar/Systray.hs
@@ -1,21 +0,0 @@--- | This is a very basic system tray widget. That said, it works--- very well since it is based on eggtraymanager.-module System.Taffybar.Systray ( systrayNew ) where--import Graphics.UI.Gtk-import Graphics.UI.Gtk.Misc.TrayManager--systrayNew :: IO Widget-systrayNew = do- box <- hBoxNew False 5-- trayManager <- trayManagerNew- Just screen <- screenGetDefault- _ <- trayManagerManageScreen trayManager screen-- _ <- on trayManager trayIconAdded $ \w -> do- widgetShowAll w- boxPackStart box w PackNatural 0-- widgetShowAll box- return (toWidget box)
− src/System/Taffybar/TaffyPager.hs
@@ -1,121 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}--------------------------------------------------------------------------------- |--- Module : System.Taffybar.TaffyPager--- Copyright : (c) José A. Romero L.--- License : BSD3-style (see LICENSE)------ Maintainer : José A. Romero L. <escherdragon@gmail.com>--- Stability : unstable--- Portability : unportable------ This module provides a drop-in replacement for the XMonadLog widget--- that allows to:------ * click on a workspace label to switch to that workspace,------ * left-click on the layout label to switch to the next layout, and--- right-click to switch to the first layout,------ * click on the window title to pop-up a list of all the currently open--- windows that can be clicked to switch to any of them,------ All its interactions with the windows manager are performed via EWMH--- hints and X11 events.------ This widget is actually only a convenience wrapper around a Pager, a--- WorkspaceSwitcher (now WorkspaceHUD), a LayoutSwitcher and a WindowSwitcher.--- If you are looking for more advanced configurations (like having components--- displayed separately, or using only part of them), consult directly the--- documentation for each of the components.-----------------------------------------------------------------------------------module System.Taffybar.TaffyPager (- -- * Usage- -- $usage- PagerConfig (..)-, defaultPagerConfig-, taffyPagerHUDLegacy-, taffyPagerHUDNew-, taffyPagerNew-) where--import Graphics.UI.Gtk-import System.Taffybar.LayoutSwitcher-import System.Taffybar.Pager-import System.Taffybar.WindowSwitcher-import System.Taffybar.WorkspaceHUD---- $usage------ This widget requires that two hooks be installed in your @xmonad.hs@--- configuration: EwmhDesktops from the XMonadContrib project, and the one--- provided in the "System.Taffybar.Hooks.PagerHints" module:------ > import XMonad.Hooks.EwmhDesktops (ewmh)--- > import System.Taffybar.Hooks.PagerHints (pagerHints)--- > main = do--- > xmonad $ ewmh $ pagerHints $ defaultConfig--- > ...------ That's all: no log hooks, no urgency hooks, no DBus client. Once you've--- configured @xmonad.hs@, you can use the widget in your @taffybar.hs@--- file:------ > import System.Taffybar.TaffyPager--- > main = do--- > let pager = taffyPagerNew defaultPagerConfig------ now you can use @pager@ as any other Taffybar widget.---- | Create a new TaffyPager widget.-{-# DEPRECATED taffyPagerNew, taffyPagerHUDLegacy- "Using PagerConfig is deprecated; Use WorkspaceHUDConfig instead." #-}-taffyPagerNew :: PagerConfig -> IO Widget-taffyPagerNew = taffyPagerHUDLegacy--taffyPagerHUDNew :: PagerConfig -> WorkspaceHUDConfig -> IO Widget-taffyPagerHUDNew cfg hudConf = do- pgr <- pagerNew cfg- whud <- buildWorkspaceHUD hudConf pgr- los <- layoutSwitcherNew pgr- wnd <- windowSwitcherNew pgr- sp1 <- separator cfg- sp2 <- separator cfg- box <- hBoxNew False 0-- boxPackStart box whud PackNatural 0- boxPackStart box sp1 PackNatural 0- boxPackStart box los PackNatural 0- boxPackStart box sp2 PackNatural 0- boxPackStart box wnd PackNatural 0-- widgetShowAll box- return (toWidget box)--taffyPagerHUDLegacy :: PagerConfig -> IO Widget-taffyPagerHUDLegacy cfg = do- pgr <- pagerNew cfg- whud <- buildWorkspaceHUD (hudFromPagerConfig cfg) pgr- los <- layoutSwitcherNew pgr- wnd <- windowSwitcherNew pgr- sp1 <- separator cfg- sp2 <- separator cfg- box <- hBoxNew False 0-- boxPackStart box whud PackNatural 0- boxPackStart box sp1 PackNatural 0- boxPackStart box los PackNatural 0- boxPackStart box sp2 PackNatural 0- boxPackStart box wnd PackNatural 0-- widgetShowAll box- return (toWidget box)---- | Create a new separator label to put between two sub-components.-separator :: PagerConfig -> IO Label-separator cfg = do- sep <- labelNew (Nothing :: Maybe String)- labelSetMarkup sep (widgetSep cfg)- return sep
− src/System/Taffybar/Text/CPUMonitor.hs
@@ -1,29 +0,0 @@-module System.Taffybar.Text.CPUMonitor(textCpuMonitorNew) where--import Text.Printf ( printf )-import qualified Text.StringTemplate as ST-import System.Information.CPU-import System.Taffybar.Widgets.PollingLabel ( pollingLabelNew )-import qualified Graphics.UI.Gtk as Gtk---- | Creates a simple textual CPU monitor. It updates once every polling--- period (in seconds).-textCpuMonitorNew :: String -- ^ Format. You can use variables: $total$, $user$, $system$- -> Double -- ^ Polling period (in seconds)- -> IO Gtk.Widget-textCpuMonitorNew fmt period = do- label <- pollingLabelNew fmt period callback- Gtk.widgetShowAll label- return label- where- callback = do- (userLoad, systemLoad, totalLoad) <- cpuLoad- let [userLoad', systemLoad', totalLoad'] = map (formatPercent.(*100)) [userLoad, systemLoad, totalLoad]- let template = ST.newSTMP fmt- let template' = ST.setManyAttrib [ ("user", userLoad'),- ("system", systemLoad'),- ("total", totalLoad') ] template- return $ ST.render template'--formatPercent :: Double -> String-formatPercent = printf "%.2f"
− src/System/Taffybar/Text/MemoryMonitor.hs
@@ -1,29 +0,0 @@-module System.Taffybar.Text.MemoryMonitor(textMemoryMonitorNew) where--import qualified Text.StringTemplate as ST-import System.Information.Memory-import System.Taffybar.Widgets.PollingLabel ( pollingLabelNew )-import qualified Graphics.UI.Gtk as Gtk---- | Creates a simple textual memory monitor. It updates once every polling--- period (in seconds).-textMemoryMonitorNew :: String -- ^ Format. You can use variables: "used", "total", "free", "buffer", "cache", "rest", "used".- -> Double -- ^ Polling period in seconds.- -> IO Gtk.Widget-textMemoryMonitorNew fmt period = do- label <- pollingLabelNew fmt period callback- Gtk.widgetShowAll label- return label- where- callback = do- info <- parseMeminfo- let template = ST.newSTMP fmt- let labels = ["used", "total", "free", "buffer", "cache", "rest", "used"]- let actions = [memoryUsed, memoryTotal, memoryFree, memoryBuffer, memoryCache, memoryRest]- actions' = map ((show . intRound).) actions- let stats = [f info | f <- actions']- let template' = ST.setManyAttrib (zip labels stats) template- return $ ST.render template'--intRound :: Double -> Int-intRound = round
− src/System/Taffybar/ToggleMonitor.hs
@@ -1,125 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--------------------------------------------------------------------------------- |--- Module : System.Taffybar.ToggleMonitor--- Copyright : (c) Ivan A. Malison--- License : BSD3-style (see LICENSE)------ Maintainer : Ivan A. Malison--- Stability : unstable--- Portability : unportable------ This module provides a dbus interface that allows users to toggle the display--- of taffybar on each monitor while it is running.--module System.Taffybar.ToggleMonitor (- handleToggleRequests,- toggleableMonitors,- withToggleSupport-) where--import Control.Applicative-import qualified Control.Concurrent.MVar as MV-import Control.Monad-import Control.Monad.Trans-import Control.Monad.Trans.Maybe-import DBus-import DBus.Client-import Data.Int-import qualified Data.Map as M-import Data.Maybe-import Graphics.UI.Gtk.Gdk.Screen-import Paths_taffybar ( getDataDir )-import Prelude-import System.Directory-import System.FilePath.Posix-import System.Taffybar-import Text.Read ( readMaybe )---- $usage------ To use this module, import it in your taffybar.hs and use the--- 'withToggleSupport' function to start taffybar, where you might otherwise--- have used 'defaultTaffybar', like so:------ > main = withToggleSupport defaultTaffybarConfig {}------ To toggle taffybar on the monitor that is currently active, issue the--- following command:------ > dbus-send --print-reply=literal --dest=taffybar.toggle /taffybar/toggle taffybar.toggle.toggleCurrent---toggleableMonitors- :: MV.MVar (M.Map Int Bool)- -> TaffybarConfigEQ- -> IO (Int -> Maybe TaffybarConfigEQ)-toggleableMonitors enabledVar cfg = do- numToEnabled <- MV.readMVar enabledVar- let fn monNumber =- if fromMaybe True $ M.lookup monNumber numToEnabled- then Just cfg- else Nothing- return fn--getActiveScreenNumber :: MaybeT IO Int-getActiveScreenNumber = do- screen <- MaybeT screenGetDefault- window <- MaybeT $ screenGetActiveWindow screen- lift $ screenGetMonitorAtWindow screen window--taffybarTogglePath :: ObjectPath-taffybarTogglePath = "/taffybar/toggle"--taffybarToggleInterface :: InterfaceName-taffybarToggleInterface = "taffybar.toggle"--toggleStateFile :: IO FilePath-toggleStateFile = (</> "toggleState.hs") <$> getDataDir--handleToggleRequests :: MV.MVar (M.Map Int Bool) -> IO () -> IO ()-handleToggleRequests enabledVar refreshTaffyWindows = do- let toggleTaffyOnMon fn mon = do- MV.modifyMVar_ enabledVar $ \numToEnabled -> do- let current = fromMaybe True $ M.lookup mon numToEnabled- result = M.insert mon (fn current) numToEnabled- flip writeFile (show result) =<< toggleStateFile- return result- refreshTaffyWindows- toggleTaffy = do- num <- runMaybeT getActiveScreenNumber- toggleTaffyOnMon not $ fromMaybe 0 num- takeInt :: (Int -> a) -> (Int32 -> a)- takeInt = (. fromIntegral)- client <- connectSession- _ <- requestName client "taffybar.toggle"- [nameAllowReplacement, nameReplaceExisting]- let interface =- defaultInterface- { interfaceName = taffybarToggleInterface- , interfaceMethods =- [ autoMethod "toggleCurrent" toggleTaffy- , autoMethod "toggleOnMonitor" $ takeInt $ toggleTaffyOnMon not- , autoMethod "hideOnMonitor" $- takeInt $ toggleTaffyOnMon (const False)- , autoMethod "showOnMonitor" $- takeInt $ toggleTaffyOnMon (const True)- ]- }- export client taffybarTogglePath interface--withToggleSupport :: TaffybarConfig -> IO ()-withToggleSupport config = do- stateFilepath <- toggleStateFile- filepathExists <- doesFileExist stateFilepath- startingMap <-- if filepathExists- then- readMaybe <$> readFile stateFilepath- else- return Nothing- enabledVar <- MV.newMVar $ fromMaybe M.empty startingMap- let modified = config { startRefresher = handleToggleRequests enabledVar- , getMonitorConfig = toggleableMonitors enabledVar- }- defaultTaffybar modified
+ src/System/Taffybar/TransparentWindow.hs view
@@ -0,0 +1,59 @@+{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE FlexibleContexts #-}+-----------------------------------------------------------------------------+-- |+-- Module : System.Taffybar.TransparentWindow+-- Copyright : (c) Ivan A. Malison+-- License : BSD3-style (see LICENSE)+--+-- Maintainer : Ivan A. Malison+-- Stability : unstable+-- Portability : unportable+--+-- Make a window transparent. Approach adapted from python code from+-- https://stackoverflow.com/questions/3908565/how-to-make-gtk-window-background-transparent/33294727#33294727+-----------------------------------------------------------------------------+module System.Taffybar.TransparentWindow where++import Control.Monad.Trans+import Control.Monad.Trans.Reader+import Data.GI.Base+import Foreign.Ptr (castPtr)+import qualified GI.Cairo+import qualified GI.Gdk as Gdk+import qualified GI.Gtk as Gtk+import Graphics.Rendering.Cairo+import Graphics.Rendering.Cairo.Internal (Render(runRender))+import Graphics.Rendering.Cairo.Types (Cairo(Cairo))++-- | This function bridges gi-cairo with the hand-written cairo package. It+-- takes a `GI.Cairo.Context` (as it appears in gi-cairo), and a `Render` action+-- (as in the cairo lib), and renders the `Render` action into the given+-- context.+renderWithContext :: GI.Cairo.Context -> Render () -> IO ()+renderWithContext ct r =+ withManagedPtr ct $ \p -> runReaderT (runRender r) (Cairo (castPtr p))++makeWindowTransparent :: MonadIO m => Gtk.Window -> m ()+makeWindowTransparent window = do+ screen <- Gtk.widgetGetScreen window+ visual <- Gdk.screenGetRgbaVisual screen+ Gtk.widgetSetVisual window visual+ Gtk.setWidgetAppPaintable window True+ _ <- Gtk.onWidgetDraw window transparentDraw+ return ()++transparentDraw :: Gtk.WidgetDrawCallback+transparentDraw context = do+ rGBA <- Gdk.newZeroRGBA+ Gdk.setRGBAAlpha rGBA 0.0+ Gdk.setRGBABlue rGBA 1.0+ Gdk.setRGBARed rGBA 1.0+ Gdk.setRGBAGreen rGBA 1.0+ Gdk.cairoSetSourceRgba context rGBA+ renderWithContext context $ do+ setOperator OperatorSource+ paint+ setOperator OperatorOver+ return False
src/System/Taffybar/Util.hs view
@@ -7,9 +7,23 @@ -- Maintainer : Ivan A. Malison -- Stability : unstable -- Portability : unportable+----------------------------------------------------------------------------- module System.Taffybar.Util where +import Control.Arrow ((&&&))+import Control.Concurrent+import Control.Monad+import Control.Monad.Trans+import Control.Monad.Trans.Reader+import Data.Tuple.Sequence+import qualified GI.GLib as GLib+import qualified GI.Gdk as Gdk+import System.Exit (ExitCode (..))+import System.Log.Logger+import qualified System.Process as P+import Text.Printf+ infixl 4 ?? (??) :: Functor f => f (a -> b) -> a -> f b fab ?? a = fmap ($ a) fab@@ -18,3 +32,44 @@ ifM :: Monad m => m Bool -> m a -> m a -> m a ifM cond whenTrue whenFalse = cond >>= (\bool -> if bool then whenTrue else whenFalse)++forkM :: Monad m => (c -> m a) -> (c -> m b) -> c -> m (a, b)+forkM a b = sequenceT . (a &&& b)++maybeToEither :: b -> Maybe a -> Either b a+maybeToEither = flip maybe Right . Left++truncateString :: Int -> String -> String+truncateString n xs+ | length xs <= n = xs+ | otherwise = take n xs ++ "…"++runOnUIThread :: MonadIO m => IO a -> m ()+runOnUIThread action =+ void $ Gdk.threadsAddIdle GLib.PRIORITY_DEFAULT $+ action >> return False++runCommandFromPath :: MonadIO m => [String] -> m (Either String String)+runCommandFromPath = runCommand "/usr/bin/env"++-- | Run the provided command with the provided arguments.+runCommand :: MonadIO m => FilePath -> [String] -> m (Either String String)+runCommand cmd args = liftIO $ do+ (ecode, stdout, stderr) <- P.readProcessWithExitCode cmd args ""+ logM "System.Taffybar.Util" INFO $+ printf "Running command %s with args %s" (show cmd) (show args)+ return $ case ecode of+ ExitSuccess -> Right stdout+ 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 delay action =+ forkIO $ forever $ action >> threadDelay (floor $ delay * 1000000)++liftActionTaker+ :: (Monad m)+ => ((a -> m a) -> m b) -> (a -> ReaderT c m a) -> ReaderT c m b+liftActionTaker actionTaker action = do+ ctx <- ask+ lift $ actionTaker $ flip runReaderT ctx . action
− src/System/Taffybar/Volume.hs
@@ -1,28 +0,0 @@-module System.Taffybar.Volume (- volumeTextNew,- volumeControlNew-) where--import System.Information.Volume-import System.Taffybar.Widgets.PollingLabel-import Graphics.UI.Gtk---- | Creates a new text volume meter-volumeTextNew :: String- -> String- -> Double- -> IO Widget-volumeTextNew mixer control pollSeconds = do- l <- pollingLabelNew "" pollSeconds . fmap show $ getVolume mixer control- widgetShowAll l- return l---- | Creates a new volume meter widget-volumeControlNew :: String -> String -> IO Widget-volumeControlNew mixer control = do- b <- volumeButtonNew- _ <- on b scaleButtonValueChanged $ \v ->- setVolume mixer control (v * 100)- let w = toWidget b- widgetShowAll w- return w
− src/System/Taffybar/Weather.hs
@@ -1,318 +0,0 @@--- | This module defines a simple textual weather widget that polls--- NOAA for weather data. To find your weather station, you can use------ <http://www.nws.noaa.gov/tg/siteloc.php>------ For example, Madison, WI is KMSN.------ NOAA provides several pieces of information in each request; you--- can control which pieces end up in your weather widget by providing--- a _template_ that is filled in with the current information. The--- template is just a 'String' with variables between dollar signs.--- The variables will be substituted with real data by the widget.--- Example:------ > let wcfg = (defaultWeatherConfig "KMSN") { weatherTemplate = "$tempC$ C @ $humidity$" }--- > weatherWidget = weatherNew wcfg 10------ This example makes a new weather widget that checks the weather at--- KMSN (Madison, WI) every 10 minutes, and displays the results in--- Celcius.------ Available variables:------ [@stationPlace@] The name of the weather station------ [@stationState@] The state that the weather station is in------ [@year@] The year the report was generated------ [@month@] The month the report was generated------ [@day@] The day the report was generated------ [@hour@] The hour the report was generated------ [@wind@] The direction and strength of the wind------ [@visibility@] Description of current visibility conditions------ [@skyCondition@] ?------ [@tempC@] The temperature in Celcius------ [@tempF@] The temperature in Farenheit------ [@dewPoint@] The current dew point------ [@humidity@] The current relative humidity------ [@pressure@] The current pressure--------- As an example, a template like------ > "$tempF$ °F"------ would yield a widget displaying the temperature in Farenheit with a--- small label after it.------ Implementation Note: the weather data parsing code is taken from--- xmobar. This version of the code makes direct HTTP requests--- instead of invoking a separate cURL process.-module System.Taffybar.Weather (- -- * Types- WeatherConfig(..),- WeatherInfo(..),- WeatherFormatter(WeatherFormatter),- -- * Constructor- weatherNew,- weatherCustomNew,- defaultWeatherConfig- ) where--import Network.HTTP-import Network.URI-import Graphics.UI.Gtk-import Text.Parsec-import Text.Printf-import Text.StringTemplate-import qualified Network.Browser as Browser--import System.Taffybar.Widgets.PollingLabel--data WeatherInfo =- WI { stationPlace :: String- , stationState :: String- , year :: String- , month :: String- , day :: String- , hour :: String- , wind :: String- , visibility :: String- , skyCondition :: String- , tempC :: Int- , tempF :: Int- , dewPoint :: String- , humidity :: Int- , pressure :: Int- } deriving (Show)----- Parsers stolen from xmobar--type Parser = Parsec String ()--pTime :: Parser (String, String, String, String)-pTime = do- y <- getNumbersAsString- _ <- char '.'- m <- getNumbersAsString- _ <- char '.'- d <- getNumbersAsString- _ <- char ' '- (h:hh:mi:mimi) <- getNumbersAsString- _ <- char ' '- return (y, m, d ,([h]++[hh]++":"++[mi]++mimi))--pTemp :: Parser (Int, Int)-pTemp = do- let num = digit <|> char '-' <|> char '.'- f <- manyTill num $ char ' '- _ <- manyTill anyChar $ char '('- c <- manyTill num $ char ' '- _ <- skipRestOfLine- return $ (floor (read c :: Double), floor (read f :: Double))--pRh :: Parser Int-pRh = do- s <- manyTill digit $ (char '%' <|> char '.')- return $ read s--pPressure :: Parser Int-pPressure = do- _ <- manyTill anyChar $ char '('- s <- manyTill digit $ char ' '- _ <- skipRestOfLine- return $ read s--parseData :: Parser WeatherInfo-parseData = do- st <- getAllBut ","- _ <- space- ss <- getAllBut "("- _ <- skipRestOfLine >> getAllBut "/"- (y,m,d,h) <- pTime- w <- getAfterString "Wind: "- v <- getAfterString "Visibility: "- sk <- getAfterString "Sky conditions: "- _ <- skipTillString "Temperature: "- (tC,tF) <- pTemp- dp <- getAfterString "Dew Point: "- _ <- skipTillString "Relative Humidity: "- rh <- pRh- _ <- skipTillString "Pressure (altimeter): "- p <- pPressure- _ <- manyTill skipRestOfLine eof- return $ WI st ss y m d h w v sk tC tF dp rh p--getAllBut :: String -> Parser String-getAllBut s =- manyTill (noneOf s) (char $ head s)--getAfterString :: String -> Parser String-getAfterString s = pAfter <|> return ("<" ++ s ++ " not found!>")- where- pAfter = do- _ <- try $ manyTill skipRestOfLine $ string s- v <- manyTill anyChar $ newline- return v--skipTillString :: String -> Parser String-skipTillString s =- manyTill skipRestOfLine $ string s--getNumbersAsString :: Parser String-getNumbersAsString = skipMany space >> many1 digit >>= \n -> return n---skipRestOfLine :: Parser Char-skipRestOfLine = do- _ <- many $ noneOf "\n\r"- newline----- | Simple: download the document at a URL. Taken from Real World--- Haskell.-downloadURL :: Maybe String -> String -> IO (Either String String)-downloadURL mProxy url = do- (_, r) <- Browser.browse $ do- case mProxy of- Just proxy -> Browser.setProxy $ Browser.Proxy proxy Nothing- Nothing -> return ()- Browser.setAllowRedirects True- Browser.request request- case rspCode r of- (2,_,_) -> return $ Right (rspBody r)- _ -> return $ Left (show r)- where- request = Request { rqURI = uri- , rqMethod = GET- , rqHeaders = []- , rqBody = ""- }- Just uri = parseURI url--getWeather :: Maybe String -> String -> IO (Either String WeatherInfo)-getWeather mProxy url = do- dat <- downloadURL mProxy url- case dat of- Right dat' -> case parse parseData url dat' of- Right d -> return (Right d)- Left err -> return (Left (show err))- Left err -> return (Left (show err))--defaultFormatter :: StringTemplate String -> WeatherInfo -> String-defaultFormatter tpl wi = render tpl'- where- tpl' = setManyAttrib [ ("stationPlace", stationPlace wi)- , ("stationState", stationState wi)- , ("year", year wi)- , ("month", month wi)- , ("day", day wi)- , ("hour", hour wi)- , ("wind", wind wi)- , ("visibility", visibility wi)- , ("skyCondition", skyCondition wi)- , ("tempC", show (tempC wi))- , ("tempF", show (tempF wi))- , ("dewPoint", dewPoint wi)- , ("humidity", show (humidity wi))- , ("pressure", show (pressure wi))- ] tpl--getCurrentWeather :: IO (Either String WeatherInfo)- -> StringTemplate String- -> StringTemplate String- -> WeatherFormatter- -> IO (String, Maybe String)-getCurrentWeather getter labelTpl tooltipTpl formatter = do- dat <- getter- case dat of- Right wi ->- return $ case formatter of- DefaultWeatherFormatter -> (escapeMarkup $ defaultFormatter labelTpl wi,- Just $ escapeMarkup $ defaultFormatter tooltipTpl wi)- WeatherFormatter f -> (f wi, Just $ f wi)-- Left err -> do- putStrLn err- return ("N/A", Nothing)---- | The NOAA URL to get data from-baseUrl :: String-baseUrl = "http://tgftp.nws.noaa.gov/data/observations/metar/decoded"---- | A wrapper to allow users to specify a custom weather formatter.--- The default interpolates variables into a string as described--- above. Custom formatters can do basically anything.-data WeatherFormatter = WeatherFormatter (WeatherInfo -> String) -- ^ Specify a custom formatter for 'WeatherInfo'- | DefaultWeatherFormatter -- ^ Use the default StringTemplate formatter---- | The configuration for the weather widget. You can provide a custom--- format string through 'weatherTemplate' as described above, or you can--- provide a custom function to turn a 'WeatherInfo' into a String via the--- 'weatherFormatter' field.-data WeatherConfig =- WeatherConfig { weatherStation :: String -- ^ The weather station to poll. No default- , weatherTemplate :: String -- ^ Template string, as described above. Default: $tempF$ °F- , weatherTemplateTooltip :: String -- ^ Template string, as described above. Default: $tempF$ °F- , weatherFormatter :: WeatherFormatter -- ^ Default: substitute in all interpolated variables (above)- , weatherProxy :: Maybe String -- ^ The proxy server, e.g. "http://proxy:port". Default: Nothing- }---- | A sensible default configuration for the weather widget that just--- renders the temperature.-defaultWeatherConfig :: String -> WeatherConfig-defaultWeatherConfig station = WeatherConfig- { weatherStation = station- , weatherTemplate = "$tempF$ °F"- , weatherTemplateTooltip = unlines ["Station: $stationPlace$",- "Time: $day$.$month$.$year$ $hour$",- "Temperature: $tempF$ °F",- "Pressure: $pressure$ hPa",- "Wind: $wind$",- "Visibility: $visibility$",- "Sky Condition: $skyCondition$",- "Dew Point: $dewPoint$",- "Humidity: $humidity$"- ]- , weatherFormatter = DefaultWeatherFormatter- , weatherProxy = Nothing}---- | Create a periodically-updating weather widget that polls NOAA.-weatherNew :: WeatherConfig -- ^ Configuration to render- -> Double -- ^ Polling period in _minutes_- -> IO Widget-weatherNew cfg delayMinutes = do- let url = printf "%s/%s.TXT" baseUrl (weatherStation cfg)- getter = getWeather (weatherProxy cfg) url- weatherCustomNew getter (weatherTemplate cfg) (weatherTemplateTooltip cfg)- (weatherFormatter cfg) delayMinutes---- | Create a periodically-updating weather widget using custom weather getter-weatherCustomNew :: IO (Either String WeatherInfo) -- ^ Weather querying action- -> String -- ^ Weather template- -> String -- ^ Weather template- -> WeatherFormatter -- ^ Weather formatter- -> Double -- ^ Polling period in _minutes_- -> IO Widget-weatherCustomNew getter labelTpl tooltipTpl formatter delayMinutes = do- let labelTpl' = newSTMP labelTpl- tooltipTpl' = newSTMP tooltipTpl-- l <- pollingLabelNewWithTooltip "N/A" (delayMinutes * 60)- (getCurrentWeather getter labelTpl' tooltipTpl' formatter)-- widgetShowAll l- return l
+ src/System/Taffybar/Widget.hs view
@@ -0,0 +1,110 @@+module System.Taffybar.Widget+ ( module System.Taffybar.Widget.Util+ -- * "System.Taffybar.Widget.Battery"+ , batteryBarNew+ , batteryBarNewWithFormat+ , textBatteryNew+ , defaultBatteryConfig++ -- * "System.Taffybar.Widget.CPUMonitor"+ , cpuMonitorNew++ -- * "System.Taffybar.Widget.CommandRunner"+ , commandRunnerNew++ -- * "System.Taffybar.Widget.Decorators"+ , module System.Taffybar.Widget.Decorators++ -- * "System.Taffybar.Widget.DiskIOMonitor"+ , dioMonitorNew++ -- * "System.Taffybar.Widget.FSMonitor"+ , fsMonitorNew++ -- * "System.Taffybar.Widget.FreedesktopNotifications"+ , Notification(..)+ , NotificationConfig(..)+ , defaultNotificationConfig+ , notifyAreaNew++ -- * "System.Taffybar.Widget.Layout"+ , LayoutConfig(..)+ , defaultLayoutConfig+ , layoutNew++ -- * "System.Taffybar.Widget.MPRIS2"+ , mpris2New++ -- * "System.Taffybar.Widget.NetworkGraph"+ , module System.Taffybar.Widget.NetworkGraph++ -- * "System.Taffybar.Widget.SNITray"+ , sniTrayNew++ -- * "System.Taffybar.Widget.SimpleClock"+ , textClockNew+ , textClockNewWith+ , defaultClockConfig+ , ClockConfig(..)++ -- * "System.Taffybar.Widget.Text.CPUMonitor"+ , module System.Taffybar.Widget.Text.CPUMonitor++ -- * "System.Taffybar.Widget.Text.MemoryMonitor"+ , module System.Taffybar.Widget.Text.MemoryMonitor++ -- * "System.Taffybar.Widget.Text.NetworkMonitor"+ , module System.Taffybar.Widget.Text.NetworkMonitor++ -- * "System.Taffybar.Widget.Volume"+ , volumeTextNew+ , volumeControlNew++ -- * "System.Taffybar.Widget.Weather"+ , WeatherConfig(..)+ , WeatherInfo(..)+ , WeatherFormatter(WeatherFormatter)+ , weatherNew+ , weatherCustomNew+ , defaultWeatherConfig++ -- * "System.Taffybar.Widget.Windows"+ , windowsNew+ , WindowsConfig(..)+ , defaultWindowsConfig+ , truncatedGetActiveLabel+ , truncatedGetMenuLabel++ -- * "System.Taffybar.Widget.Workspaces"+ , IconInfo(..)+ , Workspace(..)+ , WorkspacesConfig(..)+ , WorkspacesIO+ , hideEmpty+ , workspacesNew++ -- * "System.Taffybar.Widget.XDGMenu.MenuWidget"+ , module System.Taffybar.Widget.XDGMenu.MenuWidget+ ) where++import System.Taffybar.Widget.Battery+import System.Taffybar.Widget.CPUMonitor+import System.Taffybar.Widget.CommandRunner+import System.Taffybar.Widget.Decorators+import System.Taffybar.Widget.DiskIOMonitor+import System.Taffybar.Widget.FSMonitor+import System.Taffybar.Widget.FreedesktopNotifications+import System.Taffybar.Widget.Layout+import System.Taffybar.Widget.MPRIS2+import System.Taffybar.Widget.NetworkGraph+import System.Taffybar.Widget.SNITray+import System.Taffybar.Widget.SimpleClock+import System.Taffybar.Widget.Text.CPUMonitor+import System.Taffybar.Widget.Text.MemoryMonitor+import System.Taffybar.Widget.Text.NetworkMonitor+import System.Taffybar.Widget.Util+import System.Taffybar.Widget.Volume+import System.Taffybar.Widget.Weather+import System.Taffybar.Widget.Windows+import System.Taffybar.Widget.Workspaces+import System.Taffybar.Widget.XDGMenu.MenuWidget
+ src/System/Taffybar/Widget/Battery.hs view
@@ -0,0 +1,215 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+-----------------------------------------------------------------------------+-- |+-- Module : System.Taffybar.Widget.Battery+-- 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.Widget.Battery+ ( batteryBarNew+ , batteryBarNewWithFormat+ , textBatteryNew+ , defaultBatteryConfig+ ) where++import Control.Applicative+import qualified Control.Exception.Enclosed as E+import Control.Monad.Trans+import Data.IORef+import Data.Int (Int64)+import Graphics.UI.Gtk+import Safe (atMay)+import qualified System.IO as IO+import Text.Printf (printf)+import Text.StringTemplate++import Prelude++import System.Taffybar.Information.Battery+import System.Taffybar.Widget.Generic.PollingBar+import System.Taffybar.Widget.Generic.PollingLabel+++-- | Just the battery info that will be used for display (this makes combining+-- several easier).+data BatteryWidgetInfo = BWI+ { seconds :: Maybe Int64+ , percent :: Int+ , status :: String+ } deriving (Eq, Show)++-- | Combination for 'BatteryWidgetInfo'.+-- If one battery lacks time information, combination has no time information+combine :: [BatteryWidgetInfo] -> Maybe BatteryWidgetInfo+combine [] = Nothing+combine bs =+ Just+ BWI+ { seconds = sum <$> sequence (seconds <$> bs)+ , percent = sum (percent <$> bs) `div` length bs+ , status = status $ head bs+ }++-- | Format a duration expressed as seconds to hours and minutes+formatDuration :: Maybe Int64 -> String+formatDuration Nothing = ""+formatDuration (Just secs) = let minutes = secs `div` 60+ hours = minutes `div` 60+ minutes' = minutes `mod` 60+ in printf "%02d:%02d" hours minutes'++safeGetBatteryInfo :: IORef BatteryContext -> Int -> IO (Maybe BatteryInfo)+safeGetBatteryInfo mv i = do+ ctxt <- readIORef mv+ E.catchAny (getBatteryInfo ctxt) $ const reconnect+ where+ reconnect = do+ IO.hPutStrLn IO.stderr "reconnecting"+ ctxts <- batteryContextsNew+ let mctxt = ctxts `atMay` i+ case mctxt of+ Nothing -> IO.hPutStrLn IO.stderr "Could not reconnect to UPower"+ Just ctxt ->+ writeIORef mv ctxt+ return Nothing++getBatteryWidgetInfo :: IORef BatteryContext -> Int -> IO (Maybe BatteryWidgetInfo)+getBatteryWidgetInfo r i = do+ minfo <- safeGetBatteryInfo r i+ case minfo of+ Nothing -> return Nothing+ Just info -> do+ let battPctNum :: Int+ battPctNum = floor (batteryPercentage info)+ battTime :: Maybe Int64+ battTime = case batteryState info of+ BatteryStateCharging -> Just $ batteryTimeToFull info+ BatteryStateDischarging -> Just $ batteryTimeToEmpty info+ _ -> Nothing+ battStatus :: String+ battStatus = case batteryState info of+ BatteryStateCharging -> "Charging"+ BatteryStateDischarging -> "Discharging"+ _ -> "✔"+ return . Just $ BWI { seconds = battTime+ , percent = battPctNum+ , status = battStatus+ }+++-- | Given (maybe summarized) battery info and format: provides the string to display+formatBattInfo :: Maybe BatteryWidgetInfo -> String -> String+formatBattInfo Nothing _ = ""+formatBattInfo (Just info) fmt =+ let tpl = newSTMP fmt+ tpl' = setManyAttrib [ ("percentage", (show . percent) info)+ , ("time", formatDuration (seconds info))+ , ("status", status info)+ ] tpl+ in render tpl'++-- | Provides textual information regarding multiple batteries+battSumm :: [IORef BatteryContext] -> String -> IO String+battSumm rs fmt = do+ winfos <- traverse (uncurry getBatteryWidgetInfo) (rs `zip` [0..])+ let ws :: [BatteryWidgetInfo]+ ws = flatten winfos+ flatten [] = []+ flatten (Just a:as) = a:flatten as+ flatten (Nothing:as) = flatten as+ combined = combine ws+ return $ formatBattInfo combined fmt+++-- | A simple textual battery widget that auto-updates once every polling period+-- (specified in seconds). The displayed format is specified format string where+-- $percentage$ is replaced with the percentage of battery remaining and $time$+-- is replaced with the time until the battery is fully charged/discharged.+--+-- Multiple battery values are combined as follows:+-- - for time remaining, the largest value is used.+-- - for percentage, the mean is taken.+textBatteryNew :: [IORef BatteryContext]+ -> String -- ^ Display format+ -> Double -- ^ Poll period in seconds+ -> IO Widget+textBatteryNew [] _ _ =+ let lbl :: Maybe String+ lbl = Just "No battery"+ in toWidget <$> labelNew lbl+textBatteryNew rs fmt pollSeconds = do+ l <- pollingLabelNew "" pollSeconds (battSumm rs fmt)+ widgetShowAll l+ return l+++-- | Returns the current battery percent as a double in the range [0,+-- 1]+battPct :: IORef BatteryContext -> Int -> IO Double+battPct i r = do+ minfo <- safeGetBatteryInfo i r+ case minfo of+ Nothing -> return 0+ Just info -> return (batteryPercentage info / 100)++-- | A default configuration for the graphical battery display. The+-- bar will be red when power is critical (< 10%), green if it is full+-- (> 90%), and grey otherwise.+--+-- You can customize this with any of the options in 'BarConfig'+defaultBatteryConfig :: BarConfig+defaultBatteryConfig =+ defaultBarConfig colorFunc+ where+ colorFunc pct+ | pct < 0.1 = (1, 0, 0)+ | pct < 0.9 = (0.5, 0.5, 0.5)+ | otherwise = (0, 1, 0)+++-- | A fancy graphical battery widget that represents batteries as colored+-- vertical bars (one per battery). There is also a textual percentage reppadout+-- next to the bars, containing a summary of battery information.+batteryBarNew :: MonadIO m => BarConfig -> Double -> m Widget+batteryBarNew battCfg = liftIO .+ 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 and+-- status. An example: "$percentage$% ($time$) - $status$".+batteryBarNewWithFormat :: MonadIO m => BarConfig -> String -> Double -> m Widget+batteryBarNewWithFormat battCfg formatString pollSeconds =+ liftIO $ do+ battCtxt <- batteryContextsNew+ case battCtxt of+ [] -> do+ let lbl :: Maybe String+ lbl = Just "No battery"+ toWidget <$> labelNew lbl+ cs -> do+ b <- hBoxNew False 1+ rs <- traverse newIORef cs+ txt <- textBatteryNew rs formatString pollSeconds+ let ris :: [(IORef BatteryContext, Int)]+ ris = rs `zip` [0 ..]+ 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+ return (toWidget b)
+ src/System/Taffybar/Widget/CPUMonitor.hs view
@@ -0,0 +1,43 @@+--------------------------------------------------------------------------------+-- |+-- Module : System.Taffybar.Widget.CPUMonitor+-- Copyright : (c) José A. Romero L.+-- License : BSD3-style (see LICENSE)+--+-- Maintainer : José A. Romero L. <escherdragon@gmail.com>+-- Stability : unstable+-- Portability : unportable+--+-- Simple CPU monitor that uses a PollingGraph to visualize variations in the+-- user and system CPU times in one selected core, or in all cores available.+--+--------------------------------------------------------------------------------+module System.Taffybar.Widget.CPUMonitor where++import Control.Monad.Trans+import Data.IORef+import Graphics.UI.Gtk+import System.Taffybar.Information.CPU2 (getCPUInfo)+import System.Taffybar.Information.StreamInfo (getAccLoad)+import System.Taffybar.Widget.Generic.PollingGraph++-- | Creates a new CPU monitor. This is a PollingGraph fed by regular calls to+-- getCPUInfo, associated to an IORef used to remember the values yielded by the+-- last call to this function.+cpuMonitorNew+ :: MonadIO m+ => GraphConfig -- ^ Configuration data for the Graph.+ -> Double -- ^ Polling period (in seconds).+ -> String -- ^ Name of the core to watch (e.g. \"cpu\", \"cpu0\").+ -> m Widget+cpuMonitorNew cfg interval cpu = liftIO $ do+ info <- getCPUInfo cpu+ sample <- newIORef info+ pollingGraphNew cfg interval $ probe sample cpu++probe :: IORef [Int] -> String -> IO [Double]+probe sample cpuName = do+ load <- getAccLoad sample $ getCPUInfo cpuName+ case load of+ l0:l1:l2:_ -> return [ l0 + l1, l2 ] -- user, system+ _ -> return []
+ src/System/Taffybar/Widget/CommandRunner.hs view
@@ -0,0 +1,43 @@+--------------------------------------------------------------------------------+-- |+-- Module : System.Taffybar.Widget.CommandRunner+-- Copyright : (c) Arseniy Seroka+-- License : BSD3-style (see LICENSE)+--+-- Maintainer : Arseniy Seroka <ars.seroka@gmail.com>+-- Stability : unstable+-- Portability : unportable+--+-- Simple function which runs user defined command and+-- returns it's output in PollingLabel widget+--------------------------------------------------------------------------------++module System.Taffybar.Widget.CommandRunner ( commandRunnerNew ) where++import Control.Monad.Trans+import qualified Graphics.UI.Gtk as Gtk+import System.Log.Logger+import System.Taffybar.Util+import System.Taffybar.Widget.Generic.PollingLabel+import Text.Printf++-- | Creates a new command runner widget. This is a 'PollingLabel' fed by+-- regular calls to command given by argument. The results of calling this+-- function are displayed as string.+commandRunnerNew+ :: MonadIO m+ => Double -- ^ Polling period (in seconds).+ -> String -- ^ Command to execute. Should be in $PATH or an absolute path+ -> [String] -- ^ Command argument. May be @[]@+ -> String -- ^ If command fails this will be displayed.+ -> m Gtk.Widget+commandRunnerNew interval cmd args defaultOutput =+ pollingLabelNew "" interval $+ runCommandWithDefault cmd args defaultOutput++runCommandWithDefault :: FilePath -> [String] -> String -> IO String+runCommandWithDefault cmd args def =+ runCommand cmd args >>= either logError return+ where logError err =+ logM "System.Taffybar.Widget.CommandRunner" ERROR+ (printf "Got error in CommandRunner %s" err) >> return def
+ src/System/Taffybar/Widget/Decorators.hs view
@@ -0,0 +1,20 @@+module System.Taffybar.Widget.Decorators where++import Control.Monad.IO.Class+import qualified Graphics.UI.Gtk as Gtk+import System.Taffybar.Widget.Util++-- | Wrap a widget with two container boxes. The inner box will have the class+-- "InnerPad", and the outer box will have the class "OuterPad". These boxes can+-- be used to add padding between the outline of the widget and its contents, or+-- for the purpose of displaying a different background behind the widget.+buildPadBox :: (Gtk.WidgetClass widget, MonadIO m) => widget -> m Gtk.Widget+buildPadBox contents = liftIO $ do+ innerBox <- Gtk.hBoxNew False 0+ outerBox <- Gtk.eventBoxNew+ Gtk.containerAdd innerBox contents+ Gtk.containerAdd outerBox innerBox+ _ <- widgetSetClass innerBox "InnerPad"+ _ <- widgetSetClass outerBox "OuterPad"+ Gtk.widgetShowAll outerBox+ return $ Gtk.toWidget outerBox
+ src/System/Taffybar/Widget/DiskIOMonitor.hs view
@@ -0,0 +1,40 @@+--------------------------------------------------------------------------------+-- |+-- Module : System.Taffybar.Widget.DiskIOMonitor+-- Copyright : (c) José A. Romero L.+-- License : BSD3-style (see LICENSE)+--+-- Maintainer : José A. Romero L. <escherdragon@gmail.com>+-- Stability : unstable+-- Portability : unportable+--+-- Simple Disk IO monitor that uses a PollingGraph to visualize the speed of+-- read/write operations in one selected disk or partition.+--+--------------------------------------------------------------------------------++module System.Taffybar.Widget.DiskIOMonitor ( dioMonitorNew ) where++import Control.Monad.Trans+import qualified Graphics.UI.Gtk as Gtk+import System.Taffybar.Information.DiskIO ( getDiskTransfer )+import System.Taffybar.Widget.Generic.PollingGraph ( GraphConfig, pollingGraphNew )++-- | Creates a new disk IO monitor widget. This is a 'PollingGraph' fed by+-- regular calls to 'getDiskTransfer'. The results of calling this function+-- are normalized to the maximum value of the obtained probe (either read or+-- write transfer).+dioMonitorNew+ :: MonadIO m+ => GraphConfig -- ^ Configuration data for the Graph.+ -> Double -- ^ Polling period (in seconds).+ -> String -- ^ Name of the disk or partition to watch (e.g. \"sda\", \"sdb1\").+ -> m Gtk.Widget+dioMonitorNew cfg pollSeconds =+ pollingGraphNew cfg pollSeconds . probeDisk++probeDisk :: String -> IO [Double]+probeDisk disk = do+ transfer <- getDiskTransfer disk+ let top = foldr max 1.0 transfer+ return $ map (/top) transfer
+ src/System/Taffybar/Widget/FSMonitor.hs view
@@ -0,0 +1,41 @@+-----------------------------------------------------------------------------+-- |+-- Module : System.Taffybar.Widget.FSMonitor+-- Copyright : (c) José A. Romero L.+-- License : BSD3-style (see LICENSE)+--+-- Maintainer : José A. Romero L. <escherdragon@gmail.com>+-- Stability : unstable+-- Portability : unportable+--+-- Simple text widget that monitors the current usage of selected disk+-- partitions by regularly parsing the output of the df command in Linux+-- systems.+--+-----------------------------------------------------------------------------++module System.Taffybar.Widget.FSMonitor ( fsMonitorNew ) where++import Control.Monad.Trans+import qualified Graphics.UI.Gtk as Gtk+import System.Process ( readProcess )+import System.Taffybar.Widget.Generic.PollingLabel ( pollingLabelNew )++-- | Creates a new filesystem monitor widget. It contains one 'PollingLabel'+-- that displays the data returned by the df command. The usage level of all+-- requested partitions is extracted in one single operation.+fsMonitorNew+ :: MonadIO m+ => Double -- ^ Polling interval (in seconds, e.g. 500)+ -> [String] -- ^ Names of the partitions to monitor (e.g. [\"\/\", \"\/home\"])+ -> m Gtk.Widget+fsMonitorNew interval fsList = liftIO $ do+ label <- pollingLabelNew "" interval $ showFSInfo fsList+ Gtk.widgetShowAll label+ return $ Gtk.toWidget label++showFSInfo :: [String] -> IO String+showFSInfo fsList = do+ fsOut <- readProcess "df" ("-kP":fsList) ""+ let fss = map (take 2 . reverse . words) $ drop 1 $ lines fsOut+ return $ unwords $ map ((\s -> "[" ++ s ++ "]") . unwords) fss
+ src/System/Taffybar/Widget/FreedesktopNotifications.hs view
@@ -0,0 +1,275 @@+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+-- | This widget listens on DBus for freedesktop notifications+-- (http://developer.gnome.org/notification-spec/). Currently it is+-- somewhat ugly, but the format is somewhat configurable. A visual+-- overhaul of the widget is coming.+--+-- The widget only displays one notification at a time and+-- notifications are cancellable.++-- The notificationDaemon thread handles new notifications+-- and cancellation requests, adding or removing the notification+-- to or from the queue. It additionally starts a timeout thread+-- for each notification added to queue.+--+-- The display thread blocks idling until it is awakened to refresh the GUI+--+-- A timeout thread is associated with a notification id.+-- It sleeps until the specific timeout and then removes every notification+-- with that id from the queue++module System.Taffybar.Widget.FreedesktopNotifications+ ( Notification(..)+ , NotificationConfig(..)+ , defaultNotificationConfig+ , notifyAreaNew+ ) where++import Control.Concurrent+import Control.Concurrent.STM+import Control.Monad ( forever, void )+import Control.Monad.Trans+import DBus+import DBus.Client+import Data.Foldable+import Data.Int ( Int32 )+import Data.Map ( Map )+import Data.Monoid+import Data.Sequence ( Seq, (|>), viewl, ViewL(..) )+import qualified Data.Sequence as S+import Data.Text ( Text )+import qualified Data.Text as T+import Data.Word ( Word32 )+import Graphics.UI.Gtk hiding ( Variant )++-- | A simple structure representing a Freedesktop notification+data Notification = Notification+ { noteAppName :: Text+ , noteReplaceId :: Word32+ , noteSummary :: Text+ , noteBody :: Text+ , noteExpireTimeout :: Maybe Int32+ , noteId :: Word32+ } deriving (Show, Eq)++data NotifyState = NotifyState+ { noteWidget :: Label+ , noteContainer :: Widget+ , 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+ }++initialNoteState :: Widget -> Label -> NotificationConfig -> IO NotifyState+initialNoteState wrapper l cfg = do+ m <- newTVarIO 1+ q <- newTVarIO S.empty+ ch <- newChan+ return NotifyState { noteQueue = q+ , noteIdSource = m+ , noteWidget = l+ , noteContainer = wrapper+ , noteConfig = cfg+ , noteChan = ch+ }++-- | Removes every notification with id 'nId' from the queue+notePurge :: NotifyState -> Word32 -> IO ()+notePurge s nId = atomically . modifyTVar' (noteQueue s) $+ S.filter ((nId /=) . noteId)++-- | Removes the first (oldest) notification from the queue+noteNext :: NotifyState -> IO ()+noteNext s = atomically $ modifyTVar' (noteQueue s) aux+ where+ aux queue = case viewl queue of+ EmptyL -> S.empty+ _ :< ns -> ns++-- | Generates a fresh notification id+noteFreshId :: NotifyState -> IO Word32+noteFreshId NotifyState { noteIdSource } = atomically $ do+ nId <- readTVar noteIdSource+ writeTVar noteIdSource (succ nId)+ return nId++--------------------------------------------------------------------------------+-- | Handles a new notification+notify :: NotifyState+ -> Text -- ^ Application name+ -> Word32 -- ^ Replaces id+ -> Text -- ^ App icon+ -> Text -- ^ Summary+ -> Text -- ^ Body+ -> [Text] -- ^ Actions+ -> Map Text Variant -- ^ Hints+ -> Int32 -- ^ Expires timeout (milliseconds)+ -> IO Word32+notify s appName replaceId _ summary body _ _ timeout = do+ realId <- if replaceId == 0 then noteFreshId s else return replaceId+ let escapeText = T.pack . escapeMarkup . T.unpack+ configTimeout = notificationMaxTimeout (noteConfig s)+ realTimeout = if timeout <= 0 -- Gracefully handle out of spec negative values+ then configTimeout+ else case configTimeout of+ Nothing -> Just timeout+ Just maxTimeout -> Just (min maxTimeout timeout)+ n = Notification { noteAppName = appName+ , noteReplaceId = replaceId+ , noteSummary = escapeText summary+ , noteBody = escapeText body+ , noteExpireTimeout = realTimeout+ , noteId = realId+ }+ -- Either add the new note to the queue or replace an existing note if their ids match+ atomically $ do+ queue <- readTVar $ noteQueue s+ writeTVar (noteQueue s) $ case S.findIndexL (\n_ -> noteId n == noteId n_) queue of+ Nothing -> queue |> n+ Just index -> S.update index n queue+ startTimeoutThread s n+ wakeupDisplayThread s+ return realId++-- | Handles user cancellation of a notification+closeNotification :: NotifyState -> Word32 -> IO ()+closeNotification s nId = do+ notePurge s nId+ wakeupDisplayThread s++notificationDaemon :: (AutoMethod f1, AutoMethod f2)+ => f1 -> f2 -> IO ()+notificationDaemon onNote onCloseNote = do+ client <- connectSession+ _ <- requestName client "org.freedesktop.Notifications" [nameAllowReplacement, nameReplaceExisting]+ export client "/org/freedesktop/Notifications" interface+ where+ getServerInformation :: IO (Text, Text, Text, Text)+ getServerInformation = return ("haskell-notification-daemon",+ "nochair.net",+ "0.0.1",+ "1.1")+ getCapabilities :: IO [Text]+ getCapabilities = return ["body", "body-markup"]+ interface = defaultInterface+ { interfaceName = "org.freedesktop.Notifications"+ , interfaceMethods =+ [ autoMethod "GetServerInformation" getServerInformation+ , autoMethod "GetCapabilities" getCapabilities+ , autoMethod "CloseNotification" onCloseNote+ , autoMethod "Notify" onNote+ ]+ }++--------------------------------------------------------------------------------+wakeupDisplayThread :: NotifyState -> IO ()+wakeupDisplayThread s = writeChan (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)+ where+ formatMessage NotificationConfig {..} ns =+ take notificationMaxLength $ notificationFormatter ns++--------------------------------------------------------------------------------+startTimeoutThread :: NotifyState -> Notification -> IO ()+startTimeoutThread s Notification {..} = case noteExpireTimeout of+ Nothing -> return ()+ Just timeout -> void $ forkIO $ do+ threadDelay (fromIntegral timeout * 10^(6 :: Int))+ notePurge s noteId+ wakeupDisplayThread s++--------------------------------------------------------------------------------+data NotificationConfig = NotificationConfig+ { notificationMaxTimeout :: Maybe Int32 -- ^ Maximum time that a notification will be displayed (in seconds). Default: None+ , notificationMaxLength :: Int -- ^ Maximum length displayed, in characters. Default: 100+ , notificationFormatter :: [Notification] -> String -- ^ Function used to format notifications, takes the notifications from first to last+ }++defaultFormatter :: [Notification] -> String+defaultFormatter ns =+ let count = length ns+ n = head ns+ prefix = if count == 1+ then ""+ else "(" <> show count <> ") "+ msg = T.unpack $ if T.null (noteBody n)+ then noteSummary n+ else noteSummary n <> ": " <> noteBody n+ in "<span fgcolor='yellow'>" <> prefix <> "</span>" <> msg++-- | The default formatter is one of+-- * Summary : Body+-- * Summary+-- * (N) Summary : Body+-- * (N) Summary+-- depending on the presence of a notification body, and where N is the number of queued notifications.+defaultNotificationConfig :: NotificationConfig+defaultNotificationConfig =+ NotificationConfig { notificationMaxTimeout = Nothing+ , notificationMaxLength = 100+ , notificationFormatter = defaultFormatter+ }++-- | Create a new notification area with the given configuration.+notifyAreaNew :: MonadIO m => NotificationConfig -> m Widget+notifyAreaNew cfg = liftIO $ do+ frame <- frameNew+ box <- hBoxNew False 3+ textArea <- labelNew (Nothing :: Maybe String)+ button <- eventBoxNew+ sep <- vSeparatorNew++ bLabel <- labelNew (Nothing :: Maybe String)+ widgetSetName bLabel ("NotificationCloseButton" :: String)+ labelSetMarkup bLabel ("×" :: String)++ labelSetMaxWidthChars textArea (notificationMaxLength cfg)+ labelSetEllipsize textArea EllipsizeEnd++ containerAdd button bLabel+ boxPackStart box textArea PackGrow 0+ boxPackStart box sep PackNatural 0+ boxPackStart box button PackNatural 0++ containerAdd frame box++ widgetHide frame++ s <- initialNoteState (toWidget frame) textArea cfg+ _ <- on button buttonReleaseEvent (userCancel s)++ realizableWrapper <- hBoxNew False 0+ boxPackStart realizableWrapper frame PackNatural 0+ widgetShow realizableWrapper++ -- We can't start the dbus listener thread until we are in the GTK+ -- main loop, otherwise things are prone to lock up and block+ -- infinitely on an mvar. Bad stuff - only start the dbus thread+ -- after the fake invisible wrapper widget is realized.+ void $ on realizableWrapper realize $ do+ void $ forkIO (displayThread s)+ notificationDaemon (notify s) (closeNotification s)++ -- Don't show the widget by default - it will appear when needed+ return (toWidget realizableWrapper)+ where+ -- | Close the current note and pull up the next, if any+ userCancel s = liftIO $ do+ noteNext s+ wakeupDisplayThread s+ return True
+ src/System/Taffybar/Widget/Generic/ChannelGraph.hs view
@@ -0,0 +1,20 @@+module System.Taffybar.Widget.Generic.ChannelGraph where++import Control.Concurrent+import Control.Monad+import Control.Monad.Trans+import Graphics.UI.Gtk+import System.Taffybar.Widget.Generic.Graph++channelGraphNew+ :: MonadIO m+ => GraphConfig -> Chan a -> (a -> IO [Double]) -> m Widget+channelGraphNew config chan sampleBuilder = liftIO $ do+ (graphWidget, graphHandle) <- graphNew config+ _ <- on graphWidget realize $ do+ ourChan <- dupChan chan+ sampleThread <- forkIO $ forever $ do+ value <- readChan ourChan+ sampleBuilder value >>= graphAddSample graphHandle+ void $ on graphWidget unrealize $ killThread sampleThread+ return graphWidget
+ src/System/Taffybar/Widget/Generic/DynamicMenu.hs view
@@ -0,0 +1,32 @@+module System.Taffybar.Widget.Generic.DynamicMenu where++import Control.Monad.Trans+import qualified GI.Gtk as Gtk+import System.Taffybar.Widget.Util++data DynamicMenuConfig = DynamicMenuConfig+ { dmClickWidget :: Gtk.Widget+ , dmPopulateMenu :: Gtk.Menu -> IO ()+ }++dynamicMenuNew :: MonadIO m => DynamicMenuConfig -> m Gtk.Widget+dynamicMenuNew DynamicMenuConfig { dmClickWidget = clickWidget+ , dmPopulateMenu = populateMenu+ } = do+ bar <- Gtk.menuBarNew+ menu <- Gtk.menuNew+ menuItem <- Gtk.menuItemNew+ Gtk.containerAdd menuItem clickWidget+ Gtk.menuItemSetSubmenu menuItem $ Just menu+ Gtk.containerAdd bar menuItem+ _ <- widgetSetClassGI menu "Menu"++ _ <- Gtk.onMenuItemActivate menuItem $ populateMenu menu+ _ <- Gtk.onMenuItemDeselect menuItem $ emptyMenu menu++ Gtk.toWidget bar++emptyMenu :: (Gtk.IsContainer a, MonadIO m) => a -> m ()+emptyMenu menu =+ Gtk.containerForeach menu $ \item ->+ Gtk.containerRemove menu item >> Gtk.widgetDestroy item
+ src/System/Taffybar/Widget/Generic/Graph.hs view
@@ -0,0 +1,241 @@+{-# LANGUAGE ScopedTypeVariables #-}+-- | This is a graph widget inspired by the widget of the same name in+-- Awesome (the window manager). It plots a series of data points+-- similarly to a bar graph. This version must be explicitly fed data+-- with 'graphAddSample'. For a more automated version, see+-- 'PollingGraph'.+--+-- Like Awesome, this graph can plot multiple data sets in one widget.+-- The data sets are plotted in the order provided by the caller.+--+-- Note: all of the data fed to this widget should be in the range+-- [0,1].+module System.Taffybar.Widget.Generic.Graph (+ -- * Types+ GraphHandle+ , GraphConfig(..)+ , GraphDirection(..)+ , GraphStyle(..)+ -- * Functions+ , graphNew+ , graphAddSample+ , defaultGraphConfig+ ) where++import Control.Concurrent+import Control.Monad ( when )+import Control.Monad.Trans+import Data.Foldable ( mapM_ )+import Data.Sequence ( Seq, (<|), viewl, ViewL(..) )+import qualified Data.Sequence as S+import qualified Graphics.Rendering.Cairo as C+import qualified Graphics.Rendering.Cairo.Matrix as M+import qualified Graphics.UI.Gtk as Gtk+import Prelude hiding ( mapM_ )+import System.Taffybar.Widget.Util++newtype GraphHandle = GH (MVar GraphState)+data GraphState =+ GraphState { graphIsBootstrapped :: Bool+ , graphHistory :: [Seq Double]+ , graphCanvas :: Gtk.DrawingArea+ , graphConfig :: GraphConfig+ }++data GraphDirection = LEFT_TO_RIGHT | RIGHT_TO_LEFT deriving (Eq)++type RGBA = (Double, Double, Double, Double)++-- | The style of the graph. Generally, you will want to draw all 'Area' graphs first, and then all 'Line' graphs.+data GraphStyle+ = Area -- ^ Thea area below the value is filled+ | Line -- ^ The values are connected by a line (one pixel wide)++-- | The configuration options for the graph. The padding is the+-- number of pixels reserved as blank space around the widget in each+-- direction.+data GraphConfig = GraphConfig {+ -- | Number of pixels of padding on each side of the graph widget+ graphPadding :: Int+ -- | The background color of the graph (default black)+ , graphBackgroundColor :: RGBA+ -- | The border color drawn around the graph (default gray)+ , graphBorderColor :: RGBA+ -- | The width of the border (default 1, use 0 to disable the border)+ , graphBorderWidth :: Int+ -- | Colors for each data set (default cycles between red, green and blue)+ , graphDataColors :: [RGBA]+ -- | How to draw each data point (default @repeat Area@)+ , graphDataStyles :: [GraphStyle]+ -- | The number of data points to retain for each data set (default 20)+ , graphHistorySize :: Int+ -- | May contain Pango markup (default @Nothing@)+ , graphLabel :: Maybe String+ -- | The width (in pixels) of the graph widget (default 50)+ , graphWidth :: Int+ -- | The direction in which the graph will move as time passes (default LEFT_TO_RIGHT)+ , graphDirection :: GraphDirection+ }++defaultGraphConfig :: GraphConfig+defaultGraphConfig =+ GraphConfig+ { graphPadding = 2+ , graphBackgroundColor = (0.0, 0.0, 0.0, 1.0)+ , graphBorderColor = (0.5, 0.5, 0.5, 1.0)+ , graphBorderWidth = 1+ , graphDataColors = cycle [(1, 0, 0, 0), (0, 1, 0, 0), (0, 0, 1, 0)]+ , graphDataStyles = repeat Area+ , graphHistorySize = 20+ , graphLabel = Nothing+ , graphWidth = 50+ , graphDirection = LEFT_TO_RIGHT+ }++-- | Add a data point to the graph for each of the tracked data sets.+-- There should be as many values in the list as there are data sets.+graphAddSample :: GraphHandle -> [Double] -> IO ()+graphAddSample (GH mv) rawData = do+ s <- readMVar mv+ let drawArea = graphCanvas s+ histSize = graphHistorySize (graphConfig s)+ histsAndNewVals = zip pcts (graphHistory s)+ newHists = case graphHistory s of+ [] -> map S.singleton pcts+ _ -> map (\(p,h) -> S.take histSize $ p <| h) histsAndNewVals+ when (graphIsBootstrapped s) $ do+ modifyMVar_ mv (\s' -> return s' { graphHistory = newHists })+ Gtk.postGUIAsync $ Gtk.widgetQueueDraw drawArea+ where+ pcts = map (clamp 0 1) rawData++clamp :: Double -> Double -> Double -> Double+clamp lo hi d = max lo $ min hi d++outlineData :: (Double -> Double) -> Double -> Double -> C.Render ()+outlineData pctToY xStep pct = do+ (curX,_) <- C.getCurrentPoint+ C.lineTo (curX + xStep) (pctToY pct)++renderFrameAndBackground :: GraphConfig -> Int -> Int -> C.Render ()+renderFrameAndBackground cfg w h = do+ let (backR, backG, backB, backA) = graphBackgroundColor cfg+ (frameR, frameG, frameB, frameA) = graphBorderColor cfg+ pad = graphPadding cfg+ fpad = fromIntegral pad+ fw = fromIntegral w+ fh = fromIntegral h++ -- Draw the requested background+ C.setSourceRGBA backR backG backB backA+ C.rectangle fpad fpad (fw - 2 * fpad) (fh - 2 * fpad)+ C.fill++ -- Draw a frame around the widget area+ -- (unless equal to background color, which likely means the user does not+ -- want a frame)+ when (graphBorderWidth cfg > 0) $ do+ let p = fromIntegral (graphBorderWidth cfg)+ C.setLineWidth p+ C.setSourceRGBA frameR frameG frameB frameA+ C.rectangle (fpad + (p / 2)) (fpad + (p / 2)) (fw - 2 * fpad - p) (fh - 2 * fpad - p)+ C.stroke+++renderGraph :: [Seq Double] -> GraphConfig -> Int -> Int -> Double -> C.Render ()+renderGraph hists cfg w h xStep = do+ renderFrameAndBackground cfg w h++ C.setLineWidth 0.1++ let pad = fromIntegral $ graphPadding cfg+ let framePad = fromIntegral $ graphBorderWidth cfg++ -- Make the new origin be inside the frame and then scale the+ -- drawing area so that all operations in terms of width and height+ -- are inside the drawn frame.+ C.translate (pad + framePad) (pad + framePad)+ let xS = (fromIntegral w - 2 * pad - 2 * framePad) / fromIntegral w+ yS = (fromIntegral h - 2 * pad - 2 * framePad) / fromIntegral h+ C.scale xS yS++ -- If right-to-left direction is requested, apply an horizontal inversion+ -- transformation with an offset to the right equal to the width of the widget.+ when (graphDirection cfg == RIGHT_TO_LEFT) $+ C.transform $ M.Matrix (-1) 0 0 1 (fromIntegral w) 0++ let pctToY pct = fromIntegral h * (1 - pct)+ renderDataSet hist color style+ | S.length hist <= 1 = return ()+ | otherwise = do+ let (r, g, b, a) = color+ originY = pctToY newestSample+ originX = 0+ newestSample :< hist' = viewl hist+ C.setSourceRGBA r g b a+ C.moveTo originX originY++ mapM_ (outlineData pctToY xStep) hist'+ case style of+ Area -> do+ (endX, _) <- C.getCurrentPoint+ C.lineTo endX (fromIntegral h)+ C.lineTo 0 (fromIntegral h)+ C.fill+ Line -> do+ C.setLineWidth 1.0+ C.stroke+++ sequence_ $ zipWith3 renderDataSet hists (graphDataColors cfg) (graphDataStyles cfg)++drawBorder :: MVar GraphState -> Gtk.DrawingArea -> C.Render ()+drawBorder mv drawArea = do+ (w, h) <- widgetGetAllocatedSize drawArea+ s <- liftIO $ readMVar mv+ let cfg = graphConfig s+ renderFrameAndBackground cfg w h+ liftIO $ modifyMVar_ mv (\s' -> return s' { graphIsBootstrapped = True })+ return ()++drawGraph :: MVar GraphState -> Gtk.DrawingArea -> C.Render ()+drawGraph mv drawArea = do+ (w, h) <- widgetGetAllocatedSize drawArea+ drawBorder mv drawArea+ s <- liftIO $ readMVar mv+ let hist = graphHistory s+ cfg = graphConfig s+ histSize = graphHistorySize cfg+ -- Subtract 1 here since the first data point doesn't require+ -- any movement in the X direction+ xStep = fromIntegral w / fromIntegral (histSize - 1)++ case hist of+ [] -> renderFrameAndBackground cfg w h+ _ -> renderGraph hist cfg w h xStep++graphNew :: MonadIO m => GraphConfig -> m (Gtk.Widget, GraphHandle)+graphNew cfg = liftIO $ do+ drawArea <- Gtk.drawingAreaNew+ mv <- newMVar GraphState { graphIsBootstrapped = False+ , graphHistory = []+ , graphCanvas = drawArea+ , graphConfig = cfg+ }++ Gtk.widgetSetSizeRequest drawArea (graphWidth cfg) (-1)+ _ <- Gtk.on drawArea Gtk.draw $ drawGraph mv drawArea+ box <- Gtk.hBoxNew False 1++ case graphLabel cfg of+ Nothing -> return ()+ Just lbl -> do+ l <- Gtk.labelNew (Nothing :: Maybe String)+ Gtk.labelSetMarkup l lbl+ Gtk.boxPackStart box l Gtk.PackNatural 0++ Gtk.set drawArea [Gtk.widgetVExpand Gtk.:= True]+ Gtk.set box [Gtk.widgetVExpand Gtk.:= True]+ Gtk.boxPackStart box drawArea Gtk.PackGrow 0+ Gtk.widgetShowAll box+ return (Gtk.toWidget box, GH mv)
+ src/System/Taffybar/Widget/Generic/Icon.hs view
@@ -0,0 +1,57 @@+-- | This is a simple static image widget, and a polling image widget that+-- updates its contents by calling a callback at a set interval.+module System.Taffybar.Widget.Generic.Icon+ ( iconImageWidgetNew+ , pollingIconImageWidgetNew+ ) where++import Control.Concurrent ( forkIO, threadDelay )+import Control.Exception as E+import Control.Monad ( forever )+import Graphics.UI.Gtk++-- | Create a new widget that displays a static image+--+-- > iconImageWidgetNew path+--+-- returns a widget with icon at @path@.+iconImageWidgetNew :: FilePath -> IO Widget+iconImageWidgetNew path = imageNewFromFile path >>= putInBox++-- | Create a new widget that updates itself at regular intervals. The+-- function+--+-- > pollingIconImageWidgetNew path interval cmd+--+-- returns a widget with initial icon at @path@. The widget+-- forks a thread to update its contents every @interval@ seconds.+-- The command should return a FilePath of a valid icon.+--+-- If the IO action throws an exception, it will be swallowed and the+-- label will not update until the update interval expires.+pollingIconImageWidgetNew+ :: FilePath -- ^ Initial file path of the icon+ -> Double -- ^ Update interval (in seconds)+ -> IO FilePath -- ^ Command to run to get the input filepath+ -> IO Widget+pollingIconImageWidgetNew path interval cmd = do+ icon <- imageNewFromFile path+ _ <- on icon realize $ do+ _ <- forkIO $ forever $ do+ let tryUpdate = do+ str <- cmd+ postGUIAsync $ imageSetFromFile icon str+ E.catch tryUpdate ignoreIOException+ threadDelay $ floor (interval * 1000000)+ return ()+ putInBox icon++putInBox :: WidgetClass child => child -> IO Widget+putInBox icon = do+ box <- hBoxNew False 0+ boxPackStart box icon PackNatural 0+ widgetShowAll box+ return $ toWidget box++ignoreIOException :: IOException -> IO ()+ignoreIOException _ = return ()
+ src/System/Taffybar/Widget/Generic/PollingBar.hs view
@@ -0,0 +1,32 @@+-- | Like the vertical bar, but this widget automatically updates+-- itself with a callback at fixed intervals.+module System.Taffybar.Widget.Generic.PollingBar (+ -- * Types+ VerticalBarHandle,+ BarConfig(..),+ BarDirection(..),+ -- * Constructors and accessors+ pollingBarNew,+ verticalBarFromCallback,+ defaultBarConfig+ ) where++import Control.Concurrent+import Control.Exception.Enclosed ( tryAny )+import Graphics.UI.Gtk+import System.Taffybar.Widget.Util ( backgroundLoop, drawOn )++import System.Taffybar.Widget.Generic.VerticalBar++verticalBarFromCallback :: BarConfig -> IO Double -> IO Widget+verticalBarFromCallback cfg action = do+ (drawArea, h) <- verticalBarNew cfg+ drawOn drawArea $+ backgroundLoop $ do+ esample <- tryAny action+ traverse (verticalBarSetPercent h) esample++pollingBarNew :: BarConfig -> Double -> IO Double -> IO Widget+pollingBarNew cfg pollSeconds action =+ verticalBarFromCallback cfg $ action <* delay+ where delay = threadDelay $ floor (pollSeconds * 1000000)
+ src/System/Taffybar/Widget/Generic/PollingGraph.hs view
@@ -0,0 +1,36 @@+-- | A variant of the Graph widget that automatically updates itself+-- with a callback at a fixed interval.+module System.Taffybar.Widget.Generic.PollingGraph (+ -- * Types+ GraphHandle,+ GraphConfig(..),+ GraphDirection(..),+ GraphStyle(..),+ -- * Constructors and accessors+ pollingGraphNew,+ defaultGraphConfig+ ) where++import Control.Concurrent+import qualified Control.Exception.Enclosed as E+import Control.Monad+import Control.Monad.Trans+import Graphics.UI.Gtk+import System.Taffybar.Util+import System.Taffybar.Widget.Generic.Graph++pollingGraphNew+ :: MonadIO m+ => GraphConfig -> Double -> IO [Double] -> m Widget+pollingGraphNew cfg pollSeconds action = liftIO $ do+ (graphWidget, graphHandle) <- graphNew cfg++ _ <- on graphWidget realize $ do+ sampleThread <- foreverWithDelay pollSeconds $ do+ esample <- E.tryAny action+ case esample of+ Left _ -> return ()+ Right sample -> graphAddSample graphHandle sample+ void $ on graphWidget unrealize $ killThread sampleThread++ return graphWidget
+ src/System/Taffybar/Widget/Generic/PollingLabel.hs view
@@ -0,0 +1,59 @@+{-# LANGUAGE TupleSections #-}+-- | 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++import Control.Monad.Trans+import Control.Exception.Enclosed as E+import Control.Monad+import qualified Data.Text as T+import GI.Gtk+import qualified Graphics.UI.Gtk as Gtk2hs+import System.Taffybar.Compat.GtkLibs+import System.Taffybar.Util+import System.Taffybar.Widget.Decorators++-- | Create a new widget that updates itself at regular intervals. The+-- function+--+-- > pollingLabelNew initialString cmd interval+--+-- returns a widget with initial text @initialString@. The widget forks a thread+-- to update its contents every @interval@ seconds. The command should return a+-- string with any HTML entities escaped. This is not checked by the function,+-- since Pango markup shouldn't be escaped. Proper input sanitization is up to+-- the caller.+--+-- If the IO action throws an exception, it will be swallowed and the label will+-- not update until the update interval expires.+pollingLabelNew+ :: MonadIO m+ => String -- ^ Initial value for the label+ -> Double -- ^ Update interval (in seconds)+ -> IO String -- ^ Command to run to get the input string+ -> m Gtk2hs.Widget+pollingLabelNew initialString interval cmd =+ pollingLabelNewWithTooltip initialString interval $ (, Nothing) <$> cmd++pollingLabelNewWithTooltip+ :: MonadIO m+ => String -- ^ Initial value for the label+ -> Double -- ^ Update interval (in seconds)+ -> IO (String, Maybe String) -- ^ Command to run to get the input string+ -> m Gtk2hs.Widget+pollingLabelNewWithTooltip initialString interval cmd =+ liftIO $ buildPadBox =<< fromGIWidget =<< do+ l <- labelNew $ Just $ T.pack initialString++ let updateLabel (labelStr, tooltipStr) =+ runOnUIThread $ do+ labelSetMarkup l $ T.strip $ T.pack labelStr+ widgetSetTooltipMarkup l $ T.pack <$> tooltipStr++ _ <- onWidgetRealize l $ void $ foreverWithDelay interval $+ E.tryAny cmd >>= either (const $ return ()) updateLabel++ toWidget l
+ src/System/Taffybar/Widget/Generic/VerticalBar.hs view
@@ -0,0 +1,178 @@+-- | A vertical bar that can plot data in the range [0, 1]. The+-- colors are configurable.+module System.Taffybar.Widget.Generic.VerticalBar (+ -- * Types+ VerticalBarHandle,+ BarConfig(..),+ BarDirection(..),+ -- * Accessors/Constructors+ verticalBarNew,+ verticalBarSetPercent,+ defaultBarConfig,+ defaultBarConfigIO+ ) where++import Control.Concurrent+import Control.Monad+import Control.Monad.Trans+import qualified Graphics.Rendering.Cairo as C+import Graphics.UI.Gtk+import System.Taffybar.Widget.Util++newtype VerticalBarHandle = VBH (MVar VerticalBarState)+data VerticalBarState = VerticalBarState+ { barIsBootstrapped :: Bool+ , barPercent :: Double+ , barCanvas :: DrawingArea+ , barConfig :: BarConfig+ }++data BarDirection = HORIZONTAL | VERTICAL++data BarConfig+ = BarConfig {+ -- | Color of the border drawn around the widget+ barBorderColor :: (Double, Double, Double)+ -- | The background color of the widget+ , barBackgroundColor :: Double -> (Double, Double, Double)+ -- | A function to determine the color of the widget for the current data point+ , barColor :: Double -> (Double, Double, Double)+ -- | Number of pixels of padding around the widget+ , barPadding :: Int+ , barWidth :: Int+ , barDirection :: BarDirection}+ | BarConfigIO { barBorderColorIO :: IO (Double, Double, Double)+ , barBackgroundColorIO :: Double -> IO (Double, Double, Double)+ , barColorIO :: Double -> IO (Double, Double, Double)+ , barPadding :: Int+ , barWidth :: Int+ , barDirection :: BarDirection}++-- | A default bar configuration. The color of the active portion of+-- the bar must be specified.+defaultBarConfig :: (Double -> (Double, Double, Double)) -> BarConfig+defaultBarConfig c =+ BarConfig+ { barBorderColor = (0.5, 0.5, 0.5)+ , barBackgroundColor = const (0, 0, 0)+ , barColor = c+ , barPadding = 2+ , barWidth = 15+ , barDirection = VERTICAL+ }++defaultBarConfigIO :: (Double -> IO (Double, Double, Double)) -> BarConfig+defaultBarConfigIO c =+ BarConfigIO+ { barBorderColorIO = return (0.5, 0.5, 0.5)+ , barBackgroundColorIO = \_ -> return (0, 0, 0)+ , barColorIO = c+ , barPadding = 2+ , barWidth = 15+ , barDirection = VERTICAL+ }++verticalBarSetPercent :: VerticalBarHandle -> Double -> IO ()+verticalBarSetPercent (VBH mv) pct = do+ s <- readMVar mv+ let drawArea = barCanvas s+ when (barIsBootstrapped s) $ do+ modifyMVar_ mv (\s' -> return s' { barPercent = clamp 0 1 pct })+ postGUIAsync $ widgetQueueDraw drawArea++clamp :: Double -> Double -> Double -> Double+clamp lo hi d = max lo $ min hi d++liftedBackgroundColor :: BarConfig -> Double -> IO (Double, Double, Double)+liftedBackgroundColor bc pct =+ case bc of+ BarConfig { barBackgroundColor = bcolor } -> return (bcolor pct)+ BarConfigIO { barBackgroundColorIO = bcolor } -> bcolor pct++liftedBorderColor :: BarConfig -> IO (Double, Double, Double)+liftedBorderColor bc =+ case bc of+ BarConfig { barBorderColor = border } -> return border+ BarConfigIO { barBorderColorIO = border } -> border++liftedBarColor :: BarConfig -> Double -> IO (Double, Double, Double)+liftedBarColor bc pct =+ case bc of+ BarConfig { barColor = c } -> return (c pct)+ BarConfigIO { barColorIO = c } -> c pct++renderFrame :: Double -> BarConfig -> Int -> Int -> C.Render ()+renderFrame pct cfg width height = do+ let fwidth = fromIntegral width+ fheight = fromIntegral height++ -- Now draw the user's requested background, respecting padding+ (bgR, bgG, bgB) <- C.liftIO $ liftedBackgroundColor cfg pct+ let pad = barPadding cfg+ fpad = fromIntegral pad+ C.setSourceRGB bgR bgG bgB+ C.rectangle fpad fpad (fwidth - 2 * fpad) (fheight - 2 * fpad)+ C.fill++ -- Now draw a nice frame+ (frameR, frameG, frameB) <- C.liftIO $ liftedBorderColor cfg+ C.setSourceRGB frameR frameG frameB+ C.setLineWidth 1.0+ C.rectangle (fpad + 0.5) (fpad + 0.5) (fwidth - 2 * fpad - 1) (fheight - 2 * fpad - 1)+ C.stroke++renderBar :: Double -> BarConfig -> Int -> Int -> C.Render ()+renderBar pct cfg width height = do+ let direction = barDirection cfg+ activeHeight = case direction of+ VERTICAL -> pct * fromIntegral height+ HORIZONTAL -> fromIntegral height+ activeWidth = case direction of+ VERTICAL -> fromIntegral width+ HORIZONTAL -> pct * fromIntegral width+ newOrigin = case direction of+ VERTICAL -> fromIntegral height - activeHeight+ HORIZONTAL -> 0+ pad = barPadding cfg++ renderFrame pct cfg width height++ -- After we draw the frame, transform the coordinate space so that+ -- we only draw within the frame.+ C.translate (fromIntegral pad + 1) (fromIntegral pad + 1)+ let xS = fromIntegral (width - 2 * pad - 2) / fromIntegral width+ yS = fromIntegral (height - 2 * pad - 2) / fromIntegral height+ C.scale xS yS++ (r, g, b) <- C.liftIO $ liftedBarColor cfg pct+ C.setSourceRGB r g b+ C.translate 0 newOrigin+ C.rectangle 0 0 activeWidth activeHeight+ C.fill++drawBar :: MVar VerticalBarState -> DrawingArea -> C.Render ()+drawBar mv drawArea = do+ (w, h) <- widgetGetAllocatedSize drawArea+ s <- liftIO $ do+ s <- readMVar mv+ modifyMVar_ mv (\s' -> return s' { barIsBootstrapped = True })+ return s+ renderBar (barPercent s) (barConfig s) w h++verticalBarNew :: BarConfig -> IO (Widget, VerticalBarHandle)+verticalBarNew cfg = do+ drawArea <- drawingAreaNew+ mv <-+ newMVar+ VerticalBarState+ { barIsBootstrapped = False+ , barPercent = 0+ , barCanvas = drawArea+ , barConfig = cfg+ }+ widgetSetSizeRequest drawArea (barWidth cfg) (-1)+ _ <- on drawArea draw $ drawBar mv drawArea+ box <- hBoxNew False 1+ boxPackStart box drawArea PackGrow 0+ widgetShowAll box+ return (toWidget box, VBH mv)
+ src/System/Taffybar/Widget/Layout.hs view
@@ -0,0 +1,107 @@+-----------------------------------------------------------------------------+-- |+-- Module : System.Taffybar.Widget.Layout+-- Copyright : (c) José A. Romero L.+-- License : BSD3-style (see LICENSE)+--+-- Maintainer : José A. Romero L. <escherdragon@gmail.com>+-- Stability : unstable+-- Portability : unportable+--+-- Simple text widget that shows the XMonad layout used in the currently+-- active workspace, and that allows to change it by clicking with the+-- mouse: left-click to switch to the next layout in the list, right-click+-- to switch to the first one (as configured in @xmonad.hs@)+-----------------------------------------------------------------------------++module System.Taffybar.Widget.Layout (+ -- * Usage+ -- $usage+ LayoutConfig(..)+ , defaultLayoutConfig+ , layoutNew+) where++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 System.Taffybar.Information.X11DesktopInfo+import System.Taffybar.Widget.Util+import System.Taffybar.Context++-- $usage+--+-- This widget requires that the "System.Taffybar.Support.PagerHints" hook be+-- installed in your @xmonad.hs@:+--+-- > import System.Taffybar.Support.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.Widget.Layout+-- > main = do+-- > let los = layoutSwitcherNew defaultLayoutConfig+--+-- now you can use @los@ as any other Taffybar widget.++newtype LayoutConfig = LayoutConfig+ { formatLayout :: String -> TaffyIO String+ }++defaultLayoutConfig :: LayoutConfig+defaultLayoutConfig = LayoutConfig return++-- | Name of the X11 events to subscribe, and of the hint to look for for+-- the name of the current layout.+xLayoutProp :: String+xLayoutProp = "_XMONAD_CURRENT_LAYOUT"++-- | Create a new Layout widget that will use the given Pager as+-- its source of events.+layoutNew :: LayoutConfig -> TaffyIO Gtk.Widget+layoutNew config = do+ ctx <- ask+ label <- lift $ Gtk.labelNew (Nothing :: Maybe String)++ -- This callback is run in a separate thread and needs to use+ -- postGUIAsync+ let callback _ = liftReader Gtk.postGUIAsync $ do+ layout <- runX11Def "" $ readAsString Nothing xLayoutProp+ markup <- formatLayout config layout+ lift $ Gtk.labelSetMarkup label markup++ subscription <- subscribeToEvents [xLayoutProp] callback++ lift $ do+ ebox <- Gtk.eventBoxNew+ Gtk.containerAdd ebox label+ _ <- Gtk.on ebox Gtk.buttonPressEvent $ dispatchButtonEvent ctx+ Gtk.widgetShowAll ebox+ _ <- Gtk.on ebox W.unrealize $ flip runReaderT ctx $ unsubscribe subscription+ 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 :: Context -> Gtk.EventM Gtk.EButton Bool+dispatchButtonEvent context = do+ btn <- Gtk.eventButton+ let trigger prop =+ onClick [Gtk.SingleClick] $+ runReaderT (runX11Def () prop) context >> return True+ case btn of+ 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+-- switch to a different layout.+switch :: Int -> X11Property ()+switch n = do+ cmd <- getAtom xLayoutProp+ sendCommandEvent cmd (fromIntegral n)
+ src/System/Taffybar/Widget/MPRIS2.hs view
@@ -0,0 +1,133 @@+{-# LANGUAGE OverloadedStrings #-}+-----------------------------------------------------------------------------+-- |+-- Module : System.Taffybar.Widget.MPRIS2+-- Copyright : (c) Ivan A. Malison+-- License : BSD3-style (see LICENSE)+--+-- Maintainer : Ivan A. Malison+-- Stability : unstable+-- Portability : unportable+--+-- This is a "Now Playing" widget that listens for MPRIS events on DBus. Various+-- media players implement this. This widget works with version 2 of the MPRIS+-- protocol (https://specifications.freedesktop.org/mpris-spec/latest/).+-----------------------------------------------------------------------------+module System.Taffybar.Widget.MPRIS2 ( mpris2New ) where++import qualified Control.Concurrent.MVar as MV+import Control.Monad+import Control.Monad.Trans+import Control.Monad.Trans.Maybe+import Control.Monad.Trans.Reader+import DBus+import DBus.Client+import DBus.Internal.Types+import qualified DBus.TH as DBus+import Data.Coerce+import Data.Either.Combinators+import Data.List+import qualified Data.Text as T+import qualified GI.Gtk as Gtk+import qualified Graphics.UI.Gtk as Gtk2hs+import System.Taffybar.Compat.GtkLibs+import System.Taffybar.Context+import System.Taffybar.Information.DBusClients+import System.Taffybar.Information.MPRIS2+import System.Taffybar.Information.XDG.DesktopEntry+import System.Taffybar.Util+import System.Taffybar.Widget.Util+import Text.Printf++data MPRIS2PlayerWidget = MPRIS2PlayerWidget+ { playerLabel :: Gtk.Label+ , playerGrid :: Gtk.Grid+ }++mpris2New :: TaffyIO Gtk2hs.Widget+mpris2New = asks dbusClient >>= \client -> lift $ fromGIWidget =<< do+ grid <- Gtk.gridNew+ alignCenter grid+ playerWidgetsVar <- MV.newMVar []+ let+ newPlayerWidget :: BusName -> IO MPRIS2PlayerWidget+ newPlayerWidget busName =+ do+ -- TODO: Size the image dynamically+ pixbuf <-+ maybe (loadIcon 20 "play.svg") return =<< runMaybeT+ ( MaybeT (rightToMaybe <$> getDesktopEntry client busName)+ >>= MaybeT . getDirectoryEntryDefault+ >>= MaybeT . getImageForDesktopEntry 20+ )++ image <- Gtk.imageNewFromPixbuf $ Just pixbuf+ playerBox <- Gtk.gridNew+ label <- Gtk.labelNew Nothing++ Gtk.containerAdd playerBox image+ Gtk.containerAdd playerBox label+ alignCenter playerBox++ Gtk.widgetShowAll playerBox+ Gtk.containerAdd grid playerBox+ Gtk.widgetHide playerBox+ return MPRIS2PlayerWidget {playerLabel = label, playerGrid = playerBox}++ updatePlayerWidget+ children+ nowPlaying@NowPlaying+ { npBusName = busName+ , npStatus = status+ } =+ case lookup busName children of+ Nothing -> do+ playerWidget <- newPlayerWidget busName+ setNowPlaying playerWidget+ return $ (busName, playerWidget):children+ Just playerWidget -> setNowPlaying playerWidget >> return children+ where setNowPlaying MPRIS2PlayerWidget {playerLabel = label , playerGrid = playerBox} =+ do+ Gtk.labelSetMarkup label $ playingText 20 30 nowPlaying+ if status == "Playing"+ then+ Gtk.widgetShow playerBox+ else+ Gtk.widgetHide playerBox++ updatePlayerWidgets nowPlayings playerWidgets = do+ newWidgets <- foldM updatePlayerWidget playerWidgets nowPlayings+ let existingBusNames = map npBusName nowPlayings+ noInfoPlayerWidgets = filter ((`notElem` existingBusNames) . fst) newWidgets+ mapM_ (Gtk.widgetHide . playerGrid . snd) noInfoPlayerWidgets+ return newWidgets++ updatePlayerWidgetsVar nowPlayings =+ MV.modifyMVar_ playerWidgetsVar (updatePlayerWidgets nowPlayings)++ doUpdate = getNowPlayingInfo client >>= updatePlayerWidgetsVar+ signalCallback _ _ _ _ = doUpdate+ propMatcher =+ matchAny+ { matchPath = Just "/org/mpris/MediaPlayer2" }++ handleNameOwnerChanged _ name _ _ = do+ busNames <- map (coerce . fst) <$> MV.readMVar playerWidgetsVar+ when (name `elem` busNames) doUpdate++ _ <- Gtk.onWidgetRealize grid $ do+ updateHandler <-+ DBus.registerForPropertiesChanged client propMatcher signalCallback+ nameHandler <-+ DBus.registerForNameOwnerChanged client matchAny handleNameOwnerChanged+ void $ Gtk.onWidgetUnrealize grid $+ removeMatch client updateHandler >> removeMatch client nameHandler+ Gtk.widgetShow grid+ doUpdate+ Gtk.toWidget grid++playingText :: Int -> Int -> NowPlaying -> T.Text+playingText artistMax songMax NowPlaying { npArtists = artists, npTitle = title } = T.pack $+ Gtk2hs.escapeMarkup $ printf "%s - %s"+ (truncateString artistMax $ intercalate "," artists)+ (truncateString songMax title)
+ src/System/Taffybar/Widget/NetMonitor.hs view
@@ -0,0 +1,104 @@+{-# LANGUAGE TupleSections #-}+-----------------------------------------------------------------------------+-- |+-- Module : System.Taffybar.Widget.NetMonitor+-- Copyright : (c) José A. Romero L.+-- License : BSD3-style (see LICENSE)+--+-- Maintainer : José A. Romero L. <escherdragon@gmail.com>+-- Stability : unstable+-- Portability : unportable+--+-- Simple text widget that displays incoming\/outgoing network traffic over+-- one selected interface, as provided by the "System.Taffybar.Information.Network"+-- module.+--+-----------------------------------------------------------------------------++module System.Taffybar.Widget.NetMonitor+ {-# DEPRECATED "Use System.Taffybar.Widget.Text.NetworkMonitor instead" #-}+ ( defaultNetFormat+ , netMonitorMultiNew+ , netMonitorMultiNewWith+ , netMonitorNew+ , netMonitorNewWith+ , showInfo+ ) where++import Control.Monad.Trans+import Data.IORef+import Data.Maybe (catMaybes)+import qualified Data.Traversable as T+import Graphics.UI.Gtk+import System.Taffybar.Information.Network (getNetInfo)+import System.Taffybar.Widget.Generic.PollingLabel+import System.Taffybar.Widget.Text.NetworkMonitor++-- | Creates a new network monitor widget. It consists of two 'PollingLabel's,+-- one for incoming and one for outgoing traffic fed by regular calls to+-- 'getNetInfo'.+netMonitorNew+ :: MonadIO m+ => Double -- ^ Polling interval (in seconds, e.g. 1.5)+ -> String -- ^ Name of the network interface to monitor (e.g. \"eth0\", \"wlan1\")+ -> m Widget+netMonitorNew interval interface = liftIO $ netMonitorMultiNew interval [interface]++-- | Creates a new network monitor widget with custom template and precision.+-- Similar to 'netMonitorNew'.+--+-- The format template currently supports four units: bytes,+-- kilobytes, megabytes, and auto.+netMonitorNewWith+ :: MonadIO m+ => Double -- ^ Polling interval (in seconds, e.g. 1.5)+ -> String -- ^ Name of the network interface to monitor (e.g. \"eth0\", \"wlan1\")+ -> Int -- ^ Precision for an output+ -> String -- ^ Template for an output. You can use variables: $inB$, $inKB$, $inMB$, $inAuto$, $outB$, $outKB$, $outMB$, $outAuto$+ -> m Widget+netMonitorNewWith interval interface prec template =+ liftIO $ netMonitorMultiNewWith interval [interface] prec template++-- | Like `netMonitorNew` but allows specification of multiple interfaces.+-- Interfaces are allowed to not exist at all (e.g. unplugged usb ethernet),+-- the resulting speed is the speed of all available interfaces summed up. So+-- you get your network speed regardless of which interface you are currently+-- using.+netMonitorMultiNew+ :: MonadIO m+ => Double -- ^ Polling interval (in seconds, e.g. 1.5)+ -> [String] -- ^ Name of the network interfaces to monitor (e.g. \"eth0\", \"wlan1\")+ -> m Widget+netMonitorMultiNew interval interfaces =+ liftIO $ netMonitorMultiNewWith interval interfaces 3 defaultNetFormat++-- | Like `newMonitorNewWith` but for multiple interfaces.+netMonitorMultiNewWith+ :: MonadIO m+ => Double -- ^ Polling interval (in seconds, e.g. 1.5)+ -> [String] -- ^ Name of the network interfaces to monitor (e.g. \"eth0\", \"wlan1\")+ -> Int -- ^ Precision for an output+ -> String -- ^ Template for an output. You can use variables: $inB$, $inKB$, $inMB$, $inAuto$, $outB$, $outKB$, $outMB$, $outAuto$+ -> m Widget+netMonitorMultiNewWith interval interfaces prec template = liftIO $ do+ interfaceRefs <- T.forM interfaces $ \i -> (i,) <$> newIORef (0, 0)+ let showResult = showInfo template prec <$> calculateNetUse interfaceRefs+ label <- pollingLabelNew "" interval showResult+ widgetShowAll label+ return (toWidget label)+ where+ calculateNetUse ifaceRefs = do+ mIfaceInfos <- T.forM ifaceRefs $ \(i, ref) ->+ fmap (\ifaceInfo -> (ref, ifaceInfo)) <$> getNetInfo i+ speeds <- T.forM (catMaybes mIfaceInfos) $ \(ref, ifaceInfo) -> do+ let ii = case ifaceInfo of+ [info1, info2] -> (info1, info2)+ _ -> (0, 0)+ calcSpeed interval ref ii+ return $ foldr (\(d, u) (dsum, usum) -> (dsum + d, usum + u)) (0, 0) speeds++calcSpeed :: Double -> IORef (Int, Int) -> (Int, Int) -> IO (Double, Double)+calcSpeed interval sample result@(r1, r2) = do+ (s1, s2) <- readIORef sample+ writeIORef sample result+ return (max 0 (fromIntegral (r1 - s1) / interval), max 0 (fromIntegral (r2 - s2) / interval))
+ src/System/Taffybar/Widget/NetworkGraph.hs view
@@ -0,0 +1,23 @@+module System.Taffybar.Widget.NetworkGraph where++import Graphics.UI.Gtk+import System.Taffybar.Context+import System.Taffybar.Hooks+import System.Taffybar.Information.Network+import System.Taffybar.Widget.Generic.ChannelGraph+import System.Taffybar.Widget.Generic.Graph++logScale :: Double -> Double -> Double -> Double+logScale base maxValue value =+ logBase base (min value maxValue) / actualMax+ where actualMax = logBase base maxValue++netMonitorGraphNew :: GraphConfig -> Maybe [String] -> TaffyIO Widget+netMonitorGraphNew config interfaces = do+ NetworkInfoChan chan <- getNetworkChan+ let filterFn = maybe (const True) (flip elem) interfaces+ getUpDown = sumSpeeds . map snd . filter (filterFn . fst)+ toLogScale = logScale 2 (2 ** 32)+ toSample (up, down) = map (toLogScale . fromRational) [up, down]+ sampleBuilder = return . toSample . getUpDown+ channelGraphNew config chan sampleBuilder
+ src/System/Taffybar/Widget/SNITray.hs view
@@ -0,0 +1,52 @@+-----------------------------------------------------------------------------+-- |+-- Module : System.Taffybar.Widget.SNITray+-- Copyright : (c) Ivan A. Malison+-- License : BSD3-style (see LICENSE)+--+-- Maintainer : Ivan A. Malison+-- Stability : unstable+-- Portability : unportable+-----------------------------------------------------------------------------+module System.Taffybar.Widget.SNITray where++import Control.Monad.Trans+import Control.Monad.Trans.Reader+import qualified GI.Gtk+import Graphics.UI.GIGtkStrut+import qualified Graphics.UI.Gtk as Gtk+import qualified StatusNotifier.Host.Service as H+import StatusNotifier.Tray+import System.Posix.Process+import System.Taffybar.Compat.GtkLibs+import System.Taffybar.Context+import Text.Printf++getHost :: TaffyIO H.Host+getHost = getStateDefault $ do+ pid <- lift getProcessID+ client <- asks dbusClient+ Just host <- lift $ H.build H.defaultParams+ { H.dbusClient = Just client+ , H.uniqueIdentifier = printf "taffybar-%s" $ show pid+ }+ return host++-- | Build a new StatusNotifierItem tray that will share a host with any other+-- trays that are constructed automatically+sniTrayNew :: TaffyIO Gtk.Widget+sniTrayNew = do+ host <- getHost+ client <- asks dbusClient+ lift $ do+ tray <-+ buildTray+ TrayParams+ { trayHost = host+ , trayClient = client+ , trayOrientation = GI.Gtk.OrientationHorizontal+ , trayImageSize = Expand+ , trayIconExpand = False+ , trayAlignment = End+ }+ GI.Gtk.toWidget tray >>= fromGIWidget
+ src/System/Taffybar/Widget/SimpleClock.hs view
@@ -0,0 +1,119 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ForeignFunctionInterface #-}+-- | 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(..)+ ) where++import Control.Monad.Trans+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 Graphics.UI.Gtk++import System.Taffybar.Widget.Generic.PollingLabel+import System.Taffybar.Widget.Util++makeCalendar :: IO TimeZone -> IO Window+makeCalendar tzfn = do+ container <- windowNew+ cal <- calendarNew+ containerAdd container cal+ -- update the date on show+ _ <- on container showSignal $ resetCalendarDate cal tzfn+ -- prevent calendar from being destroyed, it can be only hidden:+ _ <- on container deleteEvent $ do+ liftIO (widgetHide container)+ return True+ return container++resetCalendarDate :: Calendar -> IO TimeZone -> IO ()+resetCalendarDate cal tzfn = do+ tz <- tzfn+ current <- Clock.getCurrentTime+ let (y,m,d) = toGregorian $ localDay $ utcToLocalTime tz current+ calendarSelectMonth cal (fromIntegral m - 1) (fromIntegral y)+ calendarSelectDay cal (fromIntegral d)++toggleCalendar :: WidgetClass w => w -> Window -> IO Bool+toggleCalendar w c = do+ isVis <- get c widgetVisible+ if isVis+ then widgetHide c+ else do+ attachPopup w "Calendar" c+ displayPopup w c+ return True++-- | 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 Widget+textClockNew userLocale =+ textClockNewWith cfg+ where+ cfg = defaultClockConfig { clockTimeLocale = userLocale }++data ClockConfig = ClockConfig { clockTimeZone :: Maybe TimeZone+ , clockTimeLocale :: Maybe L.TimeLocale+ }+ 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+ }++systemGetTZ :: IO TimeZone+systemGetTZ = setTZ >> getCurrentTimeZone++-- | 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++foreign import ccall unsafe "time.h tzset"+ c_tzset :: IO ()+#endif++-- | A configurable text-based clock widget. It currently allows for+-- 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)+ ebox <- eventBoxNew+ containerAdd ebox l+ eventBoxSetVisibleWindow ebox False+ cal <- makeCalendar $ getTZ ti+ _ <- on ebox buttonPressEvent $ onClick [SingleClick] (toggleCalendar l cal)+ widgetShowAll ebox+ return (toWidget ebox)+ where+ userZone = clockTimeZone cfg+ userLocale = clockTimeLocale cfg+ -- alternate getCurrentTime that takes a specific TZ+ getCurrentTime' :: TimeInfo -> String -> IO String+ getCurrentTime' ti f = do+ l <- getLocale ti+ z <- getTZ ti+ t <- Clock.getCurrentTime+ return $ formatTime l f $ utcToZonedTime z t+
+ src/System/Taffybar/Widget/Systray.hs view
@@ -0,0 +1,22 @@+-- | This is a very basic system tray widget. That said, it works+-- very well since it is based on eggtraymanager.+module System.Taffybar.Widget.Systray {-# DEPRECATED "Use SNITray instead" #-} ( systrayNew ) where++import Control.Monad.Trans+import Graphics.UI.Gtk+import Graphics.UI.Gtk.Misc.TrayManager++systrayNew :: MonadIO m => m Widget+systrayNew = liftIO $ do+ box <- hBoxNew False 5++ trayManager <- trayManagerNew+ Just screen <- screenGetDefault+ _ <- trayManagerManageScreen trayManager screen++ _ <- on trayManager trayIconAdded $ \w -> do+ widgetShowAll w+ boxPackStart box w PackNatural 0++ widgetShowAll box+ return (toWidget box)
+ src/System/Taffybar/Widget/Text/CPUMonitor.hs view
@@ -0,0 +1,29 @@+module System.Taffybar.Widget.Text.CPUMonitor (textCpuMonitorNew) where++import Text.Printf ( printf )+import qualified Text.StringTemplate as ST+import System.Taffybar.Information.CPU+import System.Taffybar.Widget.Generic.PollingLabel ( pollingLabelNew )+import qualified Graphics.UI.Gtk as Gtk++-- | Creates a simple textual CPU monitor. It updates once every polling+-- period (in seconds).+textCpuMonitorNew :: String -- ^ Format. You can use variables: $total$, $user$, $system$+ -> Double -- ^ Polling period (in seconds)+ -> IO Gtk.Widget+textCpuMonitorNew fmt period = do+ label <- pollingLabelNew fmt period callback+ Gtk.widgetShowAll label+ return label+ where+ callback = do+ (userLoad, systemLoad, totalLoad) <- cpuLoad+ let [userLoad', systemLoad', totalLoad'] = map (formatPercent.(*100)) [userLoad, systemLoad, totalLoad]+ let template = ST.newSTMP fmt+ let template' = ST.setManyAttrib [ ("user", userLoad'),+ ("system", systemLoad'),+ ("total", totalLoad') ] template+ return $ ST.render template'++formatPercent :: Double -> String+formatPercent = printf "%.2f"
+ src/System/Taffybar/Widget/Text/MemoryMonitor.hs view
@@ -0,0 +1,29 @@+module System.Taffybar.Widget.Text.MemoryMonitor (textMemoryMonitorNew) where++import qualified Text.StringTemplate as ST+import System.Taffybar.Information.Memory+import System.Taffybar.Widget.Generic.PollingLabel ( pollingLabelNew )+import qualified Graphics.UI.Gtk as Gtk++-- | Creates a simple textual memory monitor. It updates once every polling+-- period (in seconds).+textMemoryMonitorNew :: String -- ^ Format. You can use variables: "used", "total", "free", "buffer", "cache", "rest", "used".+ -> Double -- ^ Polling period in seconds.+ -> IO Gtk.Widget+textMemoryMonitorNew fmt period = do+ label <- pollingLabelNew fmt period callback+ Gtk.widgetShowAll label+ return label+ where+ callback = do+ info <- parseMeminfo+ let template = ST.newSTMP fmt+ let labels = ["used", "total", "free", "buffer", "cache", "rest", "used"]+ let actions = [memoryUsed, memoryTotal, memoryFree, memoryBuffer, memoryCache, memoryRest]+ actions' = map ((show . intRound).) actions+ let stats = [f info | f <- actions']+ let template' = ST.setManyAttrib (zip labels stats) template+ return $ ST.render template'++intRound :: Double -> Int+intRound = round
+ src/System/Taffybar/Widget/Text/NetworkMonitor.hs view
@@ -0,0 +1,70 @@+module System.Taffybar.Widget.Text.NetworkMonitor where++import Control.Monad+import Control.Concurrent+import Control.Monad.Trans+import Graphics.UI.Gtk+import System.Taffybar.Context+import System.Taffybar.Hooks+import System.Taffybar.Information.Network+import Text.Printf+import Text.StringTemplate++defaultNetFormat :: String+defaultNetFormat = "▼ $inAuto$ ▲ $outAuto$"++showInfo :: String -> Int -> (Double, Double) -> String+showInfo template prec (incomingb, outgoingb) =+ let+ attribs = [ ("inB", show incomingb)+ , ("inKB", toKB prec incomingb)+ , ("inMB", toMB prec incomingb)+ , ("inAuto", toAuto prec incomingb)+ , ("outB", show outgoingb)+ , ("outKB", toKB prec outgoingb)+ , ("outMB", toMB prec outgoingb)+ , ("outAuto", toAuto prec outgoingb)+ ]+ in+ render . setManyAttrib attribs $ newSTMP template++toKB :: Int -> Double -> String+toKB prec = setDigits prec . (/1024)++toMB :: Int -> Double -> String+toMB prec = setDigits prec . (/ (1024 * 1024))++setDigits :: Int -> Double -> String+setDigits dig = printf format+ where format = "%." ++ show dig ++ "f"++toAuto :: Int -> Double -> String+toAuto prec value = printf "%.*f%s" p v unit+ where value' = max 0 value+ mag :: Int+ mag = if value' == 0 then 0 else max 0 $ min 4 $ floor $ logBase 1024 value'+ v = value' / 1024 ** fromIntegral mag+ unit = case mag of+ 0 -> "B/s"+ 1 -> "KiB/s"+ 2 -> "MiB/s"+ 3 -> "GiB/s"+ 4 -> "TiB/s"+ _ -> "??B/s" -- unreachable+ p :: Int+ p = max 0 $ floor $ fromIntegral prec - logBase 10 v++networkMonitorNew :: String -> Maybe [String] -> TaffyIO Widget+networkMonitorNew template interfaces = do+ NetworkInfoChan chan <- getNetworkChan+ let filterFn = maybe (const True) (flip elem) interfaces+ liftIO $ do+ ourChan <- dupChan chan+ label <- labelNew (Nothing :: Maybe String)+ widgetShowAll label+ _ <- on label realize $ void $ forkIO $ forever $ do+ (up, down) <- sumSpeeds . map snd . filter (filterFn . fst) <$> readChan ourChan+ let labelString =+ showInfo template 3 (fromRational down, fromRational up)+ postGUIAsync $ labelSetMarkup label labelString+ return $ toWidget label
+ src/System/Taffybar/Widget/Util.hs view
@@ -0,0 +1,155 @@+-----------------------------------------------------------------------------+-- |+-- Module : System.Taffybar.Widget.Util+-- Copyright : (c) José A. Romero L.+-- License : BSD3-style (see LICENSE)+--+-- Maintainer : José A. Romero L. <escherdragon@gmail.com>+-- Stability : unstable+-- Portability : unportable+--+-- Utility functions to facilitate building GTK interfaces.+--+-----------------------------------------------------------------------------++module System.Taffybar.Widget.Util where++import Control.Concurrent ( forkIO )+import Control.Monad ( when, forever, void )+import Control.Monad.IO.Class+import Control.Monad.Trans.Maybe+import Data.Functor ( ($>) )+import Data.Int+import qualified Data.Text as T+import Data.Tuple.Sequence+import qualified GI.GdkPixbuf.Objects.Pixbuf as GI+import qualified GI.Gtk+import Graphics.UI.Gtk as Gtk+import Graphics.UI.Gtk.General.StyleContext+import System.Directory+import System.FilePath.Posix+import System.Taffybar.Compat.GtkLibs+import System.Taffybar.Information.XDG.DesktopEntry+import Text.Printf+import qualified GI.GdkPixbuf.Objects.Pixbuf as PB++import Paths_taffybar ( getDataDir )++-- | Execute the given action as a response to any of the given types+-- of mouse button clicks.+onClick :: [Click] -- ^ Types of button clicks to listen to.+ -> IO a -- ^ Action to execute.+ -> EventM EButton Bool+onClick triggers action = tryEvent $ do+ click <- eventClick+ when (click `elem` triggers) $ void $ liftIO action++-- | Attach the given widget as a popup with the given title to the+-- given window. The newly attached popup is not shown initially. Use+-- the 'displayPopup' function to display it.+attachPopup :: (WidgetClass w, WindowClass wnd) =>+ w -- ^ The widget to set as popup.+ -> String -- ^ The title of the popup.+ -> wnd -- ^ The window to attach the popup to.+ -> IO ()+attachPopup widget title window = do+ set window [ windowTitle := title+ , windowTypeHint := WindowTypeHintTooltip+ , windowSkipTaskbarHint := True+ , windowSkipPagerHint := True+ , windowTransientFor :=> getWindow+ ]+ windowSetKeepAbove window True+ windowStick window+ where getWindow = do+ Just topLevelWindow <- fmap castToWindow <$> widgetGetAncestor widget gTypeWindow+ return topLevelWindow++-- | Display the given popup widget (previously prepared using the+-- 'attachPopup' function) immediately beneath (or above) the given+-- window.+displayPopup :: (WidgetClass w, WindowClass wnd) =>+ w -- ^ The popup widget.+ -> wnd -- ^ The window the widget was attached to.+ -> IO ()+displayPopup widget window = do+ windowSetPosition window WinPosMouse+ (x, y ) <- windowGetPosition window+ (_, y') <- widgetGetSizeRequest widget+ widgetShowAll window+ if y > y'+ then windowMove window x (y - y')+ else windowMove window x y'++widgetGetAllocatedSize+ :: (WidgetClass self, MonadIO m)+ => self -> m (Int, Int)+widgetGetAllocatedSize widget =+ liftIO $+ sequenceT (widgetGetAllocatedWidth widget, widgetGetAllocatedHeight widget)++-- | Creates markup with the given foreground and background colors and the+-- given contents.+colorize :: String -- ^ Foreground color.+ -> String -- ^ Background color.+ -> String -- ^ Contents.+ -> String+colorize fg bg = printf "<span%s%s>%s</span>" (attr "fg" fg) (attr "bg" bg)+ where attr name value+ | null value = ""+ | otherwise = printf " %scolor=\"%s\"" name value++backgroundLoop :: IO a -> IO ()+backgroundLoop = void . forkIO . forever++drawOn :: WidgetClass object => object -> IO () -> IO object+drawOn drawArea action = on drawArea realize action $> drawArea++widgetSetClass+ :: (Gtk.WidgetClass widget, MonadIO m)+ => widget -> String -> m widget+widgetSetClass widget klass = liftIO $ do+ context <- Gtk.widgetGetStyleContext widget+ styleContextAddClass context klass+ return widget++widgetSetClassGI :: (GI.Gtk.IsWidget b, MonadIO m) => b -> String -> m b+widgetSetClassGI widget klass =+ GI.Gtk.toWidget widget >>= fromGIWidget >>= flip widgetSetClass klass >>+ return widget++themeLoadFlags :: [GI.Gtk.IconLookupFlags]+themeLoadFlags =+ [ GI.Gtk.IconLookupFlagsGenericFallback+ , GI.Gtk.IconLookupFlagsUseBuiltin+ ]++getImageForDesktopEntry :: Int32 -> DesktopEntry -> IO (Maybe GI.Pixbuf)+getImageForDesktopEntry size entry = runMaybeT $ do+ iconName <- MaybeT $ return $ deIcon entry+ let iconNameText = T.pack iconName+ MaybeT $ do+ iconTheme <- GI.Gtk.iconThemeGetDefault+ hasIcon <- GI.Gtk.iconThemeHasIcon iconTheme iconNameText+ if hasIcon+ then+ GI.Gtk.iconThemeLoadIcon iconTheme iconNameText size themeLoadFlags+ else do+ exists <- doesFileExist iconName+ if isAbsolute iconName && exists+ then Just <$> GI.pixbufNewFromFile iconName+ else return Nothing++alignCenter :: (GI.Gtk.IsWidget o, MonadIO m) => o -> m ()+alignCenter widget =+ GI.Gtk.setWidgetValign widget GI.Gtk.AlignCenter >>+ GI.Gtk.setWidgetHalign widget GI.Gtk.AlignCenter++pixbufNewFromFileAtScaleByHeight :: Int32 -> String -> IO PB.Pixbuf+pixbufNewFromFileAtScaleByHeight height name =+ PB.pixbufNewFromFileAtScale name (-1) height True++loadIcon :: Int32 -> String -> IO PB.Pixbuf+loadIcon height name =+ ((</> "icons" </> name) <$> getDataDir) >>=+ pixbufNewFromFileAtScaleByHeight height
+ src/System/Taffybar/Widget/Volume.hs view
@@ -0,0 +1,26 @@+module System.Taffybar.Widget.Volume+ ( volumeTextNew+ , volumeControlNew+ ) where++import Control.Monad.Trans+import Graphics.UI.Gtk+import System.Taffybar.Information.Volume+import System.Taffybar.Widget.Generic.PollingLabel++-- | Creates a new text volume meter+volumeTextNew :: MonadIO m => String -> String -> Double -> m Widget+volumeTextNew mixer control pollSeconds = liftIO $ do+ l <- pollingLabelNew "" pollSeconds . fmap show $ getVolume mixer control+ widgetShowAll l+ return l++-- | Creates a new volume meter widget+volumeControlNew :: String -> String -> IO Widget+volumeControlNew mixer control = do+ b <- volumeButtonNew+ _ <- on b scaleButtonValueChanged $ \v ->+ setVolume mixer control (v * 100)+ let w = toWidget b+ widgetShowAll w+ return w
+ src/System/Taffybar/Widget/Weather.hs view
@@ -0,0 +1,323 @@+-- | This module defines a simple textual weather widget that polls+-- NOAA for weather data. To find your weather station, you can use+--+-- <http://www.nws.noaa.gov/tg/siteloc.php>+--+-- For example, Madison, WI is KMSN.+--+-- NOAA provides several pieces of information in each request; you+-- can control which pieces end up in your weather widget by providing+-- a _template_ that is filled in with the current information. The+-- template is just a 'String' with variables between dollar signs.+-- The variables will be substituted with real data by the widget.+-- Example:+--+-- > let wcfg = (defaultWeatherConfig "KMSN") { weatherTemplate = "$tempC$ C @ $humidity$" }+-- > weatherWidget = weatherNew wcfg 10+--+-- This example makes a new weather widget that checks the weather at+-- KMSN (Madison, WI) every 10 minutes, and displays the results in+-- Celcius.+--+-- Available variables:+--+-- [@stationPlace@] The name of the weather station+--+-- [@stationState@] The state that the weather station is in+--+-- [@year@] The year the report was generated+--+-- [@month@] The month the report was generated+--+-- [@day@] The day the report was generated+--+-- [@hour@] The hour the report was generated+--+-- [@wind@] The direction and strength of the wind+--+-- [@visibility@] Description of current visibility conditions+--+-- [@skyCondition@] ?+--+-- [@tempC@] The temperature in Celcius+--+-- [@tempF@] The temperature in Farenheit+--+-- [@dewPoint@] The current dew point+--+-- [@humidity@] The current relative humidity+--+-- [@pressure@] The current pressure+--+--+-- As an example, a template like+--+-- > "$tempF$ °F"+--+-- would yield a widget displaying the temperature in Farenheit with a+-- small label after it.+--+-- Implementation Note: the weather data parsing code is taken from+-- xmobar. This version of the code makes direct HTTP requests+-- instead of invoking a separate cURL process.+module System.Taffybar.Widget.Weather+ ( WeatherConfig(..)+ , WeatherInfo(..)+ , WeatherFormatter(WeatherFormatter)+ , weatherNew+ , weatherCustomNew+ , defaultWeatherConfig+ ) where++import Control.Monad.Trans+import Graphics.UI.Gtk+import qualified Network.Browser as Browser+import Network.HTTP+import Network.URI+import Text.Parsec+import Text.Printf+import Text.StringTemplate++import System.Taffybar.Widget.Generic.PollingLabel++data WeatherInfo =+ WI { stationPlace :: String+ , stationState :: String+ , year :: String+ , month :: String+ , day :: String+ , hour :: String+ , wind :: String+ , visibility :: String+ , skyCondition :: String+ , tempC :: Int+ , tempF :: Int+ , dewPoint :: String+ , humidity :: Int+ , pressure :: Int+ } deriving (Show)+++-- Parsers stolen from xmobar++type Parser = Parsec String ()++pTime :: Parser (String, String, String, String)+pTime = do+ y <- getNumbersAsString+ _ <- char '.'+ m <- getNumbersAsString+ _ <- char '.'+ d <- getNumbersAsString+ _ <- char ' '+ (h:hh:mi:mimi) <- getNumbersAsString+ _ <- char ' '+ return (y, m, d , [h]++[hh]++":"++[mi]++mimi)++pTemp :: Parser (Int, Int)+pTemp = do+ let num = digit <|> char '-' <|> char '.'+ f <- manyTill num $ char ' '+ _ <- manyTill anyChar $ char '('+ c <- manyTill num $ char ' '+ _ <- skipRestOfLine+ return (floor (read c :: Double), floor (read f :: Double))++pRh :: Parser Int+pRh = do+ s <- manyTill digit $ char '%' <|> char '.'+ return $ read s++pPressure :: Parser Int+pPressure = do+ _ <- manyTill anyChar $ char '('+ s <- manyTill digit $ char ' '+ _ <- skipRestOfLine+ return $ read s++parseData :: Parser WeatherInfo+parseData = do+ st <- getAllBut ","+ _ <- space+ ss <- getAllBut "("+ _ <- skipRestOfLine >> getAllBut "/"+ (y,m,d,h) <- pTime+ w <- getAfterString "Wind: "+ v <- getAfterString "Visibility: "+ sk <- getAfterString "Sky conditions: "+ _ <- skipTillString "Temperature: "+ (tC,tF) <- pTemp+ dp <- getAfterString "Dew Point: "+ _ <- skipTillString "Relative Humidity: "+ rh <- pRh+ _ <- skipTillString "Pressure (altimeter): "+ p <- pPressure+ _ <- manyTill skipRestOfLine eof+ return $ WI st ss y m d h w v sk tC tF dp rh p++getAllBut :: String -> Parser String+getAllBut s =+ manyTill (noneOf s) (char $ head s)++getAfterString :: String -> Parser String+getAfterString s = pAfter <|> return ("<" ++ s ++ " not found!>")+ where+ pAfter = do+ _ <- try $ manyTill skipRestOfLine $ string s+ manyTill anyChar newline++skipTillString :: String -> Parser String+skipTillString s =+ manyTill skipRestOfLine $ string s++getNumbersAsString :: Parser String+getNumbersAsString = skipMany space >> many1 digit >>= \n -> return n+++skipRestOfLine :: Parser Char+skipRestOfLine = do+ _ <- many $ noneOf "\n\r"+ newline++-- | Simple: download the document at a URL. Taken from Real World+-- Haskell.+downloadURL :: Maybe String -> String -> IO (Either String String)+downloadURL mProxy url = do+ (_, r) <- Browser.browse $ do+ case mProxy of+ Just proxy -> Browser.setProxy $ Browser.Proxy proxy Nothing+ Nothing -> return ()+ Browser.setAllowRedirects True+ Browser.request request+ case rspCode r of+ (2,_,_) -> return $ Right (rspBody r)+ _ -> return $ Left (show r)+ where+ request = Request { rqURI = uri+ , rqMethod = GET+ , rqHeaders = []+ , rqBody = ""+ }+ Just uri = parseURI url++getWeather :: Maybe String -> String -> IO (Either String WeatherInfo)+getWeather mProxy url = do+ dat <- downloadURL mProxy url+ case dat of+ Right dat' -> case parse parseData url dat' of+ Right d -> return (Right d)+ Left err -> return (Left (show err))+ Left err -> return (Left (show err))++defaultFormatter :: StringTemplate String -> WeatherInfo -> String+defaultFormatter tpl wi = render tpl'+ where+ tpl' = setManyAttrib [ ("stationPlace", stationPlace wi)+ , ("stationState", stationState wi)+ , ("year", year wi)+ , ("month", month wi)+ , ("day", day wi)+ , ("hour", hour wi)+ , ("wind", wind wi)+ , ("visibility", visibility wi)+ , ("skyCondition", skyCondition wi)+ , ("tempC", show (tempC wi))+ , ("tempF", show (tempF wi))+ , ("dewPoint", dewPoint wi)+ , ("humidity", show (humidity wi))+ , ("pressure", show (pressure wi))+ ] tpl++getCurrentWeather :: IO (Either String WeatherInfo)+ -> StringTemplate String+ -> StringTemplate String+ -> WeatherFormatter+ -> IO (String, Maybe String)+getCurrentWeather getter labelTpl tooltipTpl formatter = do+ dat <- getter+ case dat of+ Right wi ->+ return $+ case formatter of+ DefaultWeatherFormatter ->+ ( escapeMarkup $ defaultFormatter labelTpl wi+ , Just $ escapeMarkup $ defaultFormatter tooltipTpl wi)+ WeatherFormatter f -> (f wi, Just $ f wi)+ Left err -> do+ putStrLn err+ return ("N/A", Nothing)++-- | The NOAA URL to get data from+baseUrl :: String+baseUrl = "http://tgftp.nws.noaa.gov/data/observations/metar/decoded"++-- | A wrapper to allow users to specify a custom weather formatter.+-- The default interpolates variables into a string as described+-- above. Custom formatters can do basically anything.+data WeatherFormatter+ = WeatherFormatter (WeatherInfo -> String) -- ^ Specify a custom formatter for 'WeatherInfo'+ | DefaultWeatherFormatter -- ^ Use the default StringTemplate formatter++-- | The configuration for the weather widget. You can provide a custom+-- format string through 'weatherTemplate' as described above, or you can+-- provide a custom function to turn a 'WeatherInfo' into a String via the+-- 'weatherFormatter' field.+data WeatherConfig = WeatherConfig+ { weatherStation :: String -- ^ The weather station to poll. No default+ , weatherTemplate :: String -- ^ Template string, as described above. Default: $tempF$ °F+ , weatherTemplateTooltip :: String -- ^ Template string, as described above. Default: $tempF$ °F+ , weatherFormatter :: WeatherFormatter -- ^ Default: substitute in all interpolated variables (above)+ , weatherProxy :: Maybe String -- ^ The proxy server, e.g. "http://proxy:port". Default: Nothing+ }++-- | A sensible default configuration for the weather widget that just+-- renders the temperature.+defaultWeatherConfig :: String -> WeatherConfig+defaultWeatherConfig station =+ WeatherConfig+ { weatherStation = station+ , weatherTemplate = "$tempF$ °F"+ , weatherTemplateTooltip =+ unlines+ [ "Station: $stationPlace$"+ , "Time: $day$.$month$.$year$ $hour$"+ , "Temperature: $tempF$ °F"+ , "Pressure: $pressure$ hPa"+ , "Wind: $wind$"+ , "Visibility: $visibility$"+ , "Sky Condition: $skyCondition$"+ , "Dew Point: $dewPoint$"+ , "Humidity: $humidity$"+ ]+ , weatherFormatter = DefaultWeatherFormatter+ , weatherProxy = Nothing+ }++-- | Create a periodically-updating weather widget that polls NOAA.+weatherNew :: WeatherConfig -- ^ Configuration to render+ -> Double -- ^ Polling period in _minutes_+ -> IO Widget+weatherNew cfg delayMinutes = do+ let url = printf "%s/%s.TXT" baseUrl (weatherStation cfg)+ getter = getWeather (weatherProxy cfg) url+ weatherCustomNew getter (weatherTemplate cfg) (weatherTemplateTooltip cfg)+ (weatherFormatter cfg) delayMinutes++-- | Create a periodically-updating weather widget using custom weather getter+weatherCustomNew+ :: MonadIO m+ => IO (Either String WeatherInfo) -- ^ Weather querying action+ -> String -- ^ Weather template+ -> String -- ^ Weather template+ -> WeatherFormatter -- ^ Weather formatter+ -> Double -- ^ Polling period in _minutes_+ -> m Widget+weatherCustomNew getter labelTpl tooltipTpl formatter delayMinutes = liftIO $ do+ let labelTpl' = newSTMP labelTpl+ tooltipTpl' = newSTMP tooltipTpl++ l <- pollingLabelNewWithTooltip "N/A" (delayMinutes * 60)+ (getCurrentWeather getter labelTpl' tooltipTpl' formatter)++ widgetShowAll l+ return l
+ src/System/Taffybar/Widget/Windows.hs view
@@ -0,0 +1,104 @@+{-# LANGUAGE OverloadedStrings #-}+-----------------------------------------------------------------------------+-- |+-- Module : System.Taffybar.Widget.Windows+-- Copyright : (c) José A. Romero L.+-- License : BSD3-style (see LICENSE)+--+-- Maintainer : Ivan Malison <IvanMalison@gmail.com>+-- Stability : unstable+-- Portability : unportable+--+-- Menu widget that shows the title of the currently focused window and that,+-- when clicked, displays the list of all currently open windows allowing to+-- switch to any of them.+-----------------------------------------------------------------------------++module System.Taffybar.Widget.Windows (+ -- * Usage+ -- $usage+ windowsNew+ , WindowsConfig(..)+ , defaultWindowsConfig+ , truncatedGetActiveLabel+ , truncatedGetMenuLabel+) where++import Control.Monad.Reader+import qualified Data.Text as T+import qualified GI.Gtk as Gtk+import qualified Graphics.UI.Gtk as Gtk2hs+import System.Taffybar.Compat.GtkLibs+import System.Taffybar.Context+import System.Taffybar.Information.EWMHDesktopInfo+import System.Taffybar.Util+import System.Taffybar.Widget.Generic.DynamicMenu+import System.Taffybar.Widget.Util++-- $usage+--+-- The window switcher 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+-- > ...++data WindowsConfig = WindowsConfig+ { getMenuLabel :: X11Window -> TaffyIO String+ -- ^ A monadic function that will be used to make a label for the window in+ -- the window menu.+ , getActiveLabel :: TaffyIO String+ -- ^ Action to build the label text for the active window.+ }++truncatedGetMenuLabel :: Int -> X11Window -> TaffyIO String+truncatedGetMenuLabel maxLength =+ fmap (Gtk2hs.escapeMarkup . truncateString maxLength) .+ runX11Def "(nameless window)" . getWindowTitle++truncatedGetActiveLabel :: Int -> TaffyIO String+truncatedGetActiveLabel maxLength =+ truncateString maxLength <$> runX11Def "(nameless window)" getActiveWindowTitle++defaultWindowsConfig :: WindowsConfig+defaultWindowsConfig =+ WindowsConfig+ { getMenuLabel = truncatedGetMenuLabel 35+ , getActiveLabel = truncatedGetActiveLabel 35+ }++-- | Create a new Windows widget that will use the given Pager as+-- its source of events.+windowsNew :: WindowsConfig -> TaffyIO Gtk2hs.Widget+windowsNew config = (`widgetSetClass` "Windows") =<< fromGIWidget =<< do+ label <- lift $ Gtk.labelNew Nothing++ let setLabelTitle title = lift $ runOnUIThread $ Gtk.labelSetMarkup label (T.pack title)+ activeWindowUpdatedCallback _ = getActiveLabel config >>= setLabelTitle++ subscription <- subscribeToEvents ["_NET_ACTIVE_WINDOW"] activeWindowUpdatedCallback+ _ <- liftReader (Gtk.onWidgetUnrealize label) (unsubscribe subscription)++ context <- ask++ labelWidget <- Gtk.toWidget label+ dynamicMenuNew+ DynamicMenuConfig { dmClickWidget = labelWidget+ , dmPopulateMenu = flip runReaderT context . fillMenu config+ }++-- | Populate the given menu widget with the list of all currently open windows.+fillMenu :: Gtk.IsMenuShell a => WindowsConfig -> a -> ReaderT Context IO ()+fillMenu config menu = ask >>= \context ->+ runX11Def () $ do+ windowIds <- getWindows+ forM_ windowIds $ \windowId ->+ lift $ do+ labelText <- runReaderT (getMenuLabel config windowId) context+ let focusCallback = runReaderT (runX11 $ focusWindow windowId) context >> return True+ item <- Gtk.menuItemNewWithLabel $ T.pack labelText+ _ <- Gtk.onWidgetButtonPressEvent item $ const focusCallback+ Gtk.menuShellAppend menu item+ Gtk.widgetShow item
+ src/System/Taffybar/Widget/Workspaces.hs view
@@ -0,0 +1,879 @@+{-# OPTIONS_GHC -fno-warn-type-defaults #-}+{-# LANGUAGE ScopedTypeVariables, ExistentialQuantification, RankNTypes #-}+-----------------------------------------------------------------------------+-- |+-- Module : System.Taffybar.Widget.Workspaces+-- Copyright : (c) Ivan A. Malison+-- License : BSD3-style (see LICENSE)+--+-- Maintainer : Ivan A. Malison+-- Stability : unstable+-- Portability : unportable+-----------------------------------------------------------------------------++module System.Taffybar.Widget.Workspaces+ ( ControllerConstructor+ , IconController(..)+ , IconInfo(..)+ , WWC(..)+ , WindowData(..)+ , Workspace(..)+ , WorkspaceButtonController(..)+ , WorkspaceContentsController(..)+ , WorkspaceState(..)+ , WorkspaceUnderlineController(..)+ , WorkspaceWidgetController(..)+ , WorkspacesConfig(..)+ , WorkspacesContext(..)+ , WorkspacesIO+ , buildBorderButtonController+ , buildButtonController+ , buildContentsController+ , buildIconController+ , buildLabelController+ , buildUnderlineButtonController+ , buildUnderlineController+ , buildWorkspaceData+ , defaultBuildContentsController+ , defaultGetIconInfo+ , defaultWorkspacesConfig+ , getWorkspaceToWindows+ , hideEmpty+ , liftX11Def+ , workspacesNew+ , setImage+ , windowTitleClassIconGetter+) where++import Control.Applicative+import Control.Arrow ((&&&))+import Control.Concurrent+import qualified Control.Concurrent.MVar as MV+import Control.Monad+import Control.Monad.IO.Class+import Control.Monad.Reader+import Control.RateLimit+import qualified Data.Foldable as F+import Data.List (intersect, sortBy)+import qualified Data.Map as M+import Data.Maybe+import qualified Data.MultiMap as MM+import Data.Ord+import qualified Data.Set as Set+import Data.Time.Units+import Data.Tuple.Select+import Data.Tuple.Sequence+import qualified Graphics.UI.Gtk as Gtk+import qualified Graphics.UI.Gtk.Abstract.Widget as W+import Graphics.UI.Gtk.General.StyleContext+import qualified Graphics.UI.Gtk.Layout.Table as T+import Prelude+import System.Log.Logger+import System.Taffybar.Context+import System.Taffybar.IconImages+import System.Taffybar.Information.EWMHDesktopInfo+import System.Taffybar.Information.SafeX11+import System.Taffybar.Information.X11DesktopInfo+import System.Taffybar.Util+import System.Taffybar.Widget.Decorators+import System.Taffybar.Widget.Util+import Text.Printf++data WorkspaceState+ = Active+ | Visible+ | Hidden+ | Empty+ | Urgent+ deriving (Show, Eq)++workspaceStates :: [String]+workspaceStates = map show [Active, Visible, Hidden, Empty, Urgent]++data IconInfo+ = IIEWMH EWMHIconData+ | IIFilePath FilePath+ | IIColor ColorRGBA+ | IINone+ deriving (Eq, Show)++transparentInfo :: IconInfo+transparentInfo = IIColor (0, 0, 0, 0)++data WindowData = WindowData+ { windowId :: X11Window+ , windowTitle :: String+ , windowClass :: String+ , windowUrgent :: Bool+ , windowActive :: Bool+ , windowMinimized :: Bool+ } deriving (Show, Eq)++data WidgetUpdate = WorkspaceUpdate Workspace | IconUpdate [X11Window]++data Workspace = Workspace+ { workspaceIdx :: WorkspaceIdx+ , workspaceName :: String+ , workspaceState :: WorkspaceState+ , windows :: [WindowData]+ } deriving (Show, Eq)++data WorkspacesContext = WorkspacesContext+ { controllersVar :: MV.MVar (M.Map WorkspaceIdx WWC)+ , workspacesVar :: MV.MVar (M.Map WorkspaceIdx Workspace)+ , hudWidget :: Gtk.HBox+ , hudConfig :: WorkspacesConfig+ , taffyContext :: Context+ }++type WorkspacesIO a = ReaderT WorkspacesContext IO a++liftContext :: TaffyIO a -> WorkspacesIO a+liftContext action = asks taffyContext >>= lift . runReaderT action++liftX11Def :: a -> X11Property a -> WorkspacesIO a+liftX11Def def prop = liftContext $ runX11Def def prop++setWorkspaceWidgetStatusClass+ :: W.WidgetClass widget+ => Workspace -> widget -> IO ()+setWorkspaceWidgetStatusClass workspace widget =+ updateWidgetClasses widget [show $ workspaceState workspace] workspaceStates++updateWidgetClasses+ :: W.WidgetClass widget+ => widget -> [String] -> [String] -> IO ()+updateWidgetClasses widget toAdd toRemove = do+ context <- Gtk.widgetGetStyleContext widget+ let hasClass = styleContextHasClass context+ addIfMissing klass =+ hasClass klass >>= (`when` styleContextAddClass context klass) . not+ removeIfPresent klass = unless (klass `elem` toAdd) $+ hasClass klass >>= (`when` styleContextRemoveClass context klass)+ mapM_ removeIfPresent toRemove+ mapM_ addIfMissing toAdd++class WorkspaceWidgetController wc where+ getWidget :: wc -> Gtk.Widget+ updateWidget :: wc -> WidgetUpdate -> WorkspacesIO wc+ updateWidgetX11 :: wc -> WidgetUpdate -> WorkspacesIO wc+ updateWidgetX11 cont _ = return cont++data WWC = forall a. WorkspaceWidgetController a => WWC a++instance WorkspaceWidgetController WWC where+ getWidget (WWC wc) = getWidget wc+ updateWidget (WWC wc) update = WWC <$> updateWidget wc update+ updateWidgetX11 (WWC wc) update = WWC <$> updateWidgetX11 wc update++type ControllerConstructor = Workspace -> WorkspacesIO WWC+type ParentControllerConstructor =+ ControllerConstructor -> ControllerConstructor++data WorkspacesConfig =+ WorkspacesConfig+ { widgetBuilder :: ControllerConstructor+ , widgetGap :: Int+ , windowIconSize :: Int+ , underlineHeight :: Int+ , minWSWidgetSize :: Maybe Int+ , underlinePadding :: Int+ , maxIcons :: Maybe Int+ , minIcons :: Int+ , getIconInfo :: WindowData -> WorkspacesIO IconInfo+ , labelSetter :: Workspace -> WorkspacesIO String+ , showWorkspaceFn :: Workspace -> Bool+ , borderWidth :: Int+ , updateEvents :: [String]+ , updateRateLimitMicroseconds :: Integer+ , iconSort :: [WindowData] -> WorkspacesIO [WindowData]+ , urgentWorkspaceState :: Bool+ }++windowTitleClassIconGetter+ :: (Bool -> String -> String -> IconInfo)+ -> (WindowData -> WorkspacesIO IconInfo)+windowTitleClassIconGetter customIconF = fn+ where+ fn w@WindowData {windowTitle = wTitle, windowClass = wClass} = do+ ewmhIcon <- defaultGetIconInfo w+ let hasEwmhIcon = ewmhIcon /= IINone+ custIcon = customIconF hasEwmhIcon wTitle wClass+ hasCustomIcon = custIcon /= IINone+ return $ if hasCustomIcon then custIcon else ewmhIcon++defaultWorkspacesConfig :: WorkspacesConfig+defaultWorkspacesConfig =+ WorkspacesConfig+ { widgetBuilder = buildButtonController defaultBuildContentsController+ , widgetGap = 0+ , windowIconSize = 16+ , underlineHeight = 4+ , minWSWidgetSize = Just 30+ , underlinePadding = 1+ , maxIcons = Nothing+ , minIcons = 0+ , getIconInfo = defaultGetIconInfo+ , labelSetter = return . workspaceName+ , showWorkspaceFn = const True+ , borderWidth = 2+ , iconSort = sortWindowsByPosition+ , updateEvents =+ [ "WM_HINTS"+ , "_NET_CURRENT_DESKTOP"+ , "_NET_DESKTOP_NAMES"+ , "_NET_NUMBER_OF_DESKTOPS"+ , "_NET_WM_DESKTOP"+ , "_NET_WM_STATE_HIDDEN"+ ]+ , updateRateLimitMicroseconds = 100000+ , urgentWorkspaceState = False+ }++hideEmpty :: Workspace -> Bool+hideEmpty Workspace { workspaceState = Empty } = False+hideEmpty _ = True++wLog :: MonadIO m => Priority -> String -> m ()+wLog l s = liftIO $ logM "System.Taffybar.Widget.Workspaces" l s++updateVar :: MV.MVar a -> (a -> WorkspacesIO a) -> WorkspacesIO a+updateVar var modify = do+ ctx <- ask+ lift $ MV.modifyMVar var $ fmap (\a -> (a, a)) . flip runReaderT ctx . modify++updateWorkspacesVar :: WorkspacesIO (M.Map WorkspaceIdx Workspace)+updateWorkspacesVar = do+ workspacesRef <- asks workspacesVar+ updateVar workspacesRef buildWorkspaceData++getWorkspaceToWindows :: [X11Window] -> X11Property (MM.MultiMap WorkspaceIdx X11Window)+getWorkspaceToWindows =+ foldM+ (\theMap window ->+ MM.insert <$> getWorkspace window <*> pure window <*> pure theMap)+ MM.empty++getWindowData :: [X11Window]+ -> [X11Window]+ -> X11Window+ -> X11Property WindowData+getWindowData activeWindows urgentWindows window = do+ wTitle <- getWindowTitle window+ wClass <- getWindowClass window+ wMinimized <- getWindowStateProperty window "_NET_WM_STATE_HIDDEN"+ return+ WindowData+ { windowId = window+ , windowTitle = wTitle+ , windowClass = wClass+ , windowUrgent = window `elem` urgentWindows+ , windowActive = window `elem` activeWindows+ , windowMinimized = wMinimized+ }++buildWorkspaceData :: M.Map WorkspaceIdx Workspace+ -> WorkspacesIO (M.Map WorkspaceIdx Workspace)+buildWorkspaceData _ = ask >>= \context -> liftX11Def M.empty $ do+ names <- getWorkspaceNames+ wins <- getWindows+ workspaceToWindows <- getWorkspaceToWindows wins+ urgentWindows <- filterM isWindowUrgent wins+ activeWindows <- readAsListOfWindow Nothing "_NET_ACTIVE_WINDOW"+ active:visible <- getVisibleWorkspaces+ let getWorkspaceState idx ws+ | idx == active = Active+ | idx `elem` visible = Visible+ | urgentWorkspaceState (hudConfig context) &&+ not (null (ws `intersect` urgentWindows)) =+ Urgent+ | null ws = Empty+ | otherwise = Hidden+ foldM+ (\theMap (idx, name) -> do+ let ws = MM.lookup idx workspaceToWindows+ windowInfos <- mapM (getWindowData activeWindows urgentWindows) ws+ return $+ M.insert+ idx+ Workspace+ { workspaceIdx = idx+ , workspaceName = name+ , workspaceState = getWorkspaceState idx ws+ , windows = windowInfos+ }+ theMap)+ M.empty+ names++addWidgetsToTopLevel :: WorkspacesIO ()+addWidgetsToTopLevel = do+ WorkspacesContext+ { controllersVar = controllersRef+ , hudWidget = cont+ } <- ask+ controllersMap <- lift $ MV.readMVar controllersRef+ -- Elems returns elements in ascending order of their keys so this will always+ -- add the widgets in the correct order+ mapM_ addWidget $ M.elems controllersMap+ lift $ Gtk.widgetShowAll cont++addWidget :: WWC -> WorkspacesIO ()+addWidget controller = do+ cont <- asks hudWidget+ let workspaceWidget = getWidget controller+ lift $ do+ -- XXX: This hbox exists to (hopefully) prevent the issue where workspace+ -- widgets appear out of order, in the switcher, by acting as an empty+ -- place holder when the actual widget is hidden.+ hbox <- Gtk.hBoxNew False 0+ parent <- Gtk.widgetGetParent workspaceWidget+ if isJust parent+ then Gtk.widgetReparent (getWidget controller) hbox+ else Gtk.containerAdd hbox workspaceWidget+ Gtk.containerAdd cont hbox++workspacesNew :: WorkspacesConfig -> TaffyIO Gtk.Widget+workspacesNew cfg = ask >>= \tContext -> lift $ do+ cont <- Gtk.hBoxNew False (widgetGap cfg)+ controllersRef <- MV.newMVar M.empty+ workspacesRef <- MV.newMVar M.empty+ let context =+ WorkspacesContext+ { controllersVar = controllersRef+ , workspacesVar = workspacesRef+ , hudWidget = cont+ , hudConfig = cfg+ , taffyContext = tContext+ }+ -- This will actually create all the widgets+ runReaderT updateAllWorkspaceWidgets context+ updateHandler <- onWorkspaceUpdate context+ iconHandler <- onIconsChanged context+ (workspaceSubscription, iconSubscription) <-+ flip runReaderT tContext $ sequenceT+ ( subscribeToEvents (updateEvents cfg) $ lift . updateHandler+ , subscribeToEvents ["_NET_WM_ICON"] (lift . onIconChanged iconHandler)+ )+ let doUnsubscribe = flip runReaderT tContext $+ mapM_ unsubscribe [iconSubscription, workspaceSubscription]+ _ <- Gtk.on cont W.unrealize doUnsubscribe+ return $ Gtk.toWidget cont++updateAllWorkspaceWidgets :: WorkspacesIO ()+updateAllWorkspaceWidgets = do+ wLog DEBUG "-Workspace- -Execute-..."++ workspacesMap <- updateWorkspacesVar+ wLog DEBUG $ printf "Workspaces: %s" $ show workspacesMap++ wLog DEBUG "-Workspace- Adding and removing widgets..."+ updateWorkspaceControllers++ let updateController' idx controller =+ maybe (return controller)+ (updateWidget controller . WorkspaceUpdate) $+ M.lookup idx workspacesMap+ logUpdateController i =+ wLog DEBUG $ printf "-Workspace- -each- Updating %s widget" $ show i+ updateController i cont = logUpdateController i >>+ updateController' i cont++ doWidgetUpdate updateController++ wLog DEBUG "-Workspace- Showing and hiding controllers..."+ setControllerWidgetVisibility++setControllerWidgetVisibility :: WorkspacesIO ()+setControllerWidgetVisibility = do+ WorkspacesContext { workspacesVar = workspacesRef+ , controllersVar = controllersRef+ , hudConfig = cfg+ } <- ask+ lift $ do+ workspacesMap <- MV.readMVar workspacesRef+ controllersMap <- MV.readMVar controllersRef+ forM_ (M.elems workspacesMap) $ \ws ->+ let c = M.lookup (workspaceIdx ws) controllersMap+ mWidget = getWidget <$> c+ action = if showWorkspaceFn cfg ws+ then Gtk.widgetShow+ else Gtk.widgetHide+ in+ maybe (return ()) action mWidget++doWidgetUpdate :: (WorkspaceIdx -> WWC -> WorkspacesIO WWC) -> WorkspacesIO ()+doWidgetUpdate updateController = do+ c@WorkspacesContext { controllersVar = controllersRef } <- ask+ lift $ MV.modifyMVar_ controllersRef $ \controllers -> do+ controllersList <-+ mapM+ (\(idx, controller) -> do+ newController <- runReaderT (updateController idx controller) c+ return (idx, newController)) $+ M.toList controllers+ return $ M.fromList controllersList++updateWorkspaceControllers :: WorkspacesIO ()+updateWorkspaceControllers = do+ WorkspacesContext { controllersVar = controllersRef+ , workspacesVar = workspacesRef+ , hudWidget = cont+ , hudConfig = cfg+ } <- ask+ workspacesMap <- lift $ MV.readMVar workspacesRef+ controllersMap <- lift $ MV.readMVar controllersRef++ let newWorkspacesSet = M.keysSet workspacesMap+ existingWorkspacesSet = M.keysSet controllersMap++ when (existingWorkspacesSet /= newWorkspacesSet) $ do+ let addWorkspaces = Set.difference newWorkspacesSet existingWorkspacesSet+ removeWorkspaces = Set.difference existingWorkspacesSet newWorkspacesSet+ builder = widgetBuilder cfg++ _ <- updateVar controllersRef $ \controllers -> do+ let oldRemoved = F.foldl (flip M.delete) controllers removeWorkspaces+ buildController idx = builder <$> M.lookup idx workspacesMap+ buildAndAddController theMap idx =+ maybe (return theMap) (>>= return . flip (M.insert idx) theMap)+ (buildController idx)+ foldM buildAndAddController oldRemoved $ Set.toList addWorkspaces+ -- Clear the container and repopulate it+ lift $ Gtk.containerForeach cont (Gtk.containerRemove cont)+ addWidgetsToTopLevel++rateLimitFn+ :: forall req resp.+ WorkspacesContext+ -> (req -> IO resp)+ -> ResultsCombiner req resp+ -> IO (req -> IO resp)+rateLimitFn context =+ let limit = (updateRateLimitMicroseconds $ hudConfig context)+ rate = fromMicroseconds limit :: Microsecond in+ generateRateLimitedFunction $ PerInvocation rate++onWorkspaceUpdate :: WorkspacesContext -> IO (Event -> IO ())+onWorkspaceUpdate context = do+ rateLimited <- rateLimitFn context doUpdate combineRequests+ let withLog event = do+ case event of+ PropertyEvent _ _ _ _ _ atom _ _ ->+ wLog DEBUG $ printf "-Event- -Workspace- %s" $ show atom+ _ -> wLog DEBUG "-Event- -Workspace-"+ void $ forkIO $ rateLimited event+ return withLog+ where+ combineRequests _ b = Just (b, const ((), ()))+ doUpdate _ = Gtk.postGUIAsync $ runReaderT updateAllWorkspaceWidgets context++onIconChanged :: (Set.Set X11Window -> IO ()) -> Event -> IO ()+onIconChanged handler event =+ case event of+ PropertyEvent { ev_window = wid } -> do+ wLog DEBUG $ printf "-Icon- -Event- %s" $ show wid+ handler $ Set.singleton wid+ _ -> return ()++onIconsChanged :: WorkspacesContext -> IO (Set.Set X11Window -> IO ())+onIconsChanged context =+ (.) (void . forkIO) <$> rateLimitFn context onIconsChanged' combineRequests+ where+ combineRequests windows1 windows2 =+ Just (Set.union windows1 windows2, const ((), ()))+ onIconsChanged' wids = do+ wLog DEBUG $ printf "-Icon- -Execute- %s" $ show wids+ flip runReaderT context $+ doWidgetUpdate+ (\idx c ->+ wLog DEBUG (printf "-Icon- -each- Updating %s icons." $ show idx) >>+ updateWidget c (IconUpdate $ Set.toList wids))++data WorkspaceContentsController = WorkspaceContentsController+ { containerWidget :: Gtk.Widget+ , contentsControllers :: [WWC]+ }++buildContentsController :: [ControllerConstructor] -> ControllerConstructor+buildContentsController constructors ws = do+ controllers <- mapM ($ ws) constructors+ tempController <- lift $ do+ cons <- Gtk.hBoxNew False 0+ mapM_ (Gtk.containerAdd cons . getWidget) controllers+ outerBox <- buildPadBox cons+ _ <- widgetSetClass cons "Contents"+ return+ WorkspaceContentsController+ { containerWidget = Gtk.toWidget outerBox+ , contentsControllers = controllers+ }+ WWC <$> updateWidget tempController (WorkspaceUpdate ws)++defaultBuildContentsController :: ControllerConstructor+defaultBuildContentsController =+ buildContentsController [buildLabelController, buildIconController]++instance WorkspaceWidgetController WorkspaceContentsController where+ getWidget = containerWidget+ updateWidget cc update = do+ WorkspacesContext {hudConfig = cfg} <- ask+ lift $+ maybe (return ()) (updateMinSize $ Gtk.toWidget $ containerWidget cc) $+ minWSWidgetSize cfg+ case update of+ WorkspaceUpdate newWorkspace ->+ lift $ setWorkspaceWidgetStatusClass newWorkspace $ containerWidget cc+ _ -> return ()+ newControllers <- mapM (`updateWidget` update) $ contentsControllers cc+ return cc {contentsControllers = newControllers}+ updateWidgetX11 cc update = do+ newControllers <- mapM (`updateWidgetX11` update) $ contentsControllers cc+ return cc {contentsControllers = newControllers}++newtype LabelController = LabelController { label :: Gtk.Label }++buildLabelController :: ControllerConstructor+buildLabelController ws = do+ tempController <- lift $ do+ lbl <- Gtk.labelNew (Nothing :: Maybe String)+ _ <- widgetSetClass lbl "WorkspaceLabel"+ return LabelController { label = lbl }+ WWC <$> updateWidget tempController (WorkspaceUpdate ws)++instance WorkspaceWidgetController LabelController where+ getWidget = Gtk.toWidget . label+ updateWidget lc (WorkspaceUpdate newWorkspace) = do+ WorkspacesContext { hudConfig = cfg } <- ask+ labelText <- labelSetter cfg newWorkspace+ lift $ do+ Gtk.labelSetMarkup (label lc) labelText+ setWorkspaceWidgetStatusClass newWorkspace $ label lc+ return lc+ updateWidget lc _ = return lc++data IconWidget = IconWidget+ { iconContainer :: Gtk.EventBox+ , iconImage :: Gtk.Image+ , iconWindow :: MV.MVar (Maybe WindowData)+ }++data IconController = IconController+ { iconsContainer :: Gtk.HBox+ , iconImages :: [IconWidget]+ , iconWorkspace :: Workspace+ }++buildIconController :: ControllerConstructor+buildIconController ws = do+ tempController <-+ lift $ do+ hbox <- Gtk.hBoxNew False 0+ return+ IconController+ {iconsContainer = hbox, iconImages = [], iconWorkspace = ws}+ WWC <$> updateWidget tempController (WorkspaceUpdate ws)++instance WorkspaceWidgetController IconController where+ getWidget = Gtk.toWidget . iconsContainer+ updateWidget ic (WorkspaceUpdate newWorkspace) = do+ newImages <- updateImages ic newWorkspace+ return ic { iconImages = newImages, iconWorkspace = newWorkspace }+ updateWidget ic (IconUpdate updatedIcons) =+ updateWindowIconsById ic updatedIcons >> return ic++updateWindowIconsById :: IconController+ -> [X11Window]+ -> WorkspacesIO ()+updateWindowIconsById ic windowIds =+ mapM_ maybeUpdateWindowIcon $ iconImages ic+ where+ maybeUpdateWindowIcon widget =+ do+ info <- lift $ MV.readMVar $ iconWindow widget+ when (maybe False (flip elem windowIds . windowId) info) $+ updateIconWidget ic widget info False++updateMinSize :: Gtk.Widget -> Int -> IO ()+updateMinSize widget minWidth = do+ W.widgetSetSizeRequest widget (-1) (-1)+ W.Requisition w _ <- W.widgetSizeRequest widget+ when (w < minWidth) $ W.widgetSetSizeRequest widget minWidth $ -1++defaultGetIconInfo :: WindowData -> WorkspacesIO IconInfo+defaultGetIconInfo w =+ maybe IINone IIEWMH <$> liftX11Def Nothing (getWindowIconsData $ windowId w)++sortWindowsByPosition :: [WindowData] -> WorkspacesIO [WindowData]+sortWindowsByPosition wins = do+ let getGeometryWorkspaces w = getDisplay >>= liftIO . (`safeGetGeometry` w)+ getGeometries = mapM+ (forkM return ((((sel2 &&& sel3) <$>) .) getGeometryWorkspaces) . windowId)+ wins+ windowGeometries <- liftX11Def [] getGeometries+ let getLeftPos wd =+ fromMaybe (999999999, 99999999) $ lookup (windowId wd) windowGeometries+ compareWindowData a b =+ compare+ (windowMinimized a, getLeftPos a)+ (windowMinimized b, getLeftPos b)+ return $ sortBy compareWindowData wins++updateImages :: IconController -> Workspace -> WorkspacesIO [IconWidget]+updateImages ic ws = do+ WorkspacesContext {hudConfig = cfg} <- ask+ sortedWindows <- iconSort cfg $ windows ws+ let updateIconWidget' getImageAction wdata ton = do+ iconWidget <- getImageAction+ _ <- updateIconWidget ic iconWidget wdata ton+ return iconWidget+ existingImages = map return $ iconImages ic+ buildAndAddIconWidget = do+ iw <- buildIconWidget ws+ lift $ Gtk.containerAdd (iconsContainer ic) $ iconContainer iw+ return iw+ infiniteImages = existingImages ++ repeat buildAndAddIconWidget+ windowCount = length $ windows ws+ maxNeeded = maybe windowCount (min windowCount) $ maxIcons cfg+ newImagesNeeded = length existingImages < max (minIcons cfg) maxNeeded+ -- XXX: Only one of the two things being zipped can be an infinite list,+ -- which is why this newImagesNeeded contortion is needed.+ imgSrcs =+ if newImagesNeeded+ then infiniteImages+ else existingImages+ getImgs = maybe imgSrcs (`take` imgSrcs) $ maxIcons cfg+ justWindows = map Just sortedWindows+ windowDatas =+ if newImagesNeeded+ then justWindows +++ replicate (minIcons cfg - length justWindows) Nothing+ else justWindows ++ repeat Nothing+ transparentOnNones = replicate (minIcons cfg) True ++ repeat False+ newImgs <-+ sequence $ zipWith3 updateIconWidget' getImgs windowDatas transparentOnNones+ when newImagesNeeded $ lift $ Gtk.widgetShowAll $ iconsContainer ic+ return newImgs++buildIconWidget :: Workspace -> WorkspacesIO IconWidget+buildIconWidget ws = do+ ctx <- ask+ lift $ do+ img <- Gtk.imageNew+ ebox <- Gtk.eventBoxNew+ windowVar <- MV.newMVar Nothing+ _ <- widgetSetClass img "IconImage"+ _ <- widgetSetClass ebox "IconContainer"+ Gtk.containerAdd ebox img+ _ <-+ Gtk.on ebox Gtk.buttonPressEvent $+ liftIO $ do+ info <- MV.readMVar windowVar+ case info of+ Just updatedInfo ->+ flip runReaderT ctx $ liftX11Def () $ focusWindow $ windowId updatedInfo+ _ -> liftIO $ void $ switch ctx (workspaceIdx ws)+ return True+ return+ IconWidget {iconContainer = ebox, iconImage = img, iconWindow = windowVar}++getWindowStatusString :: WindowData -> String+getWindowStatusString WindowData { windowMinimized = True } = "Minimized"+getWindowStatusString WindowData { windowActive = True } = show Active+getWindowStatusString WindowData { windowUrgent = True } = show Urgent+getWindowStatusString _ = "Normal"++possibleStatusStrings :: [String]+possibleStatusStrings = [show Active, show Urgent, "Minimized", "Normal", "Nodata"]++updateIconWidget+ :: IconController+ -> IconWidget+ -> Maybe WindowData+ -> Bool+ -> WorkspacesIO ()+updateIconWidget _ IconWidget+ { iconContainer = iconButton+ , iconImage = image+ , iconWindow = windowRef+ } windowData transparentOnNone = do+ cfg <- asks hudConfig++ let setIconWidgetProperties = do+ info <- maybe (return IINone) (getIconInfo cfg) windowData+ let imgSize = windowIconSize cfg+ statusString = maybe "nodata" getWindowStatusString windowData+ iconInfo =+ case info of+ IINone ->+ if transparentOnNone+ then transparentInfo+ else IINone+ _ -> info+ lift $ do+ mpixBuf <- getPixBuf imgSize iconInfo+ setImage imgSize image mpixBuf+ updateWidgetClasses iconButton [statusString] possibleStatusStrings++ void $ updateVar windowRef $ const $ setIconWidgetProperties >> return windowData++setImage :: Int -> Gtk.Image -> Maybe Gtk.Pixbuf -> IO ()+setImage imgSize img pixBuf =+ case pixBuf of+ Just pixbuf -> do+ scaledPixbuf <- scalePixbuf imgSize pixbuf+ Gtk.imageSetFromPixbuf img scaledPixbuf+ Nothing -> Gtk.imageClear img++selectEWMHIcon :: Int -> [EWMHIcon] -> EWMHIcon+selectEWMHIcon imgSize icons = head prefIcon+ where sortedIcons = sortBy (comparing height) icons+ smallestLargerIcon = take 1 $ dropWhile ((<= imgSize) . height) sortedIcons+ largestIcon = take 1 $ reverse sortedIcons+ prefIcon = smallestLargerIcon ++ largestIcon++getPixBuf :: Int -> IconInfo -> IO (Maybe Gtk.Pixbuf)+getPixBuf imgSize = gpb+ where+ 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++data WorkspaceButtonController = WorkspaceButtonController+ { button :: Gtk.EventBox+ , buttonWorkspace :: Workspace+ , contentsController :: WWC+ }++buildButtonController :: ParentControllerConstructor+buildButtonController contentsBuilder workspace = do+ cc <- contentsBuilder workspace+ workspacesRef <- asks workspacesVar+ ctx <- ask+ lift $ do+ ebox <- Gtk.eventBoxNew+ Gtk.containerAdd ebox $ getWidget cc+ Gtk.eventBoxSetVisibleWindow ebox False+ _ <-+ Gtk.on ebox Gtk.scrollEvent $ do+ workspaces <- liftIO $ MV.readMVar workspacesRef+ let switchOne a =+ liftIO $+ flip runReaderT ctx $+ liftX11Def+ ()+ (switchOneWorkspace a (length (M.toList workspaces) - 1)) >>+ return True+ dir <- Gtk.eventScrollDirection+ case dir of+ Gtk.ScrollUp -> switchOne True+ Gtk.ScrollLeft -> switchOne True+ Gtk.ScrollDown -> switchOne False+ Gtk.ScrollRight -> switchOne False+ Gtk.ScrollSmooth -> return False+ _ <- Gtk.on ebox Gtk.buttonPressEvent $ switch ctx $ workspaceIdx workspace+ return $+ WWC+ WorkspaceButtonController+ {button = ebox, buttonWorkspace = workspace, contentsController = cc}++switch :: (MonadIO m) => WorkspacesContext -> WorkspaceIdx -> m Bool+switch ctx idx = do+ liftIO $ flip runReaderT ctx $ liftX11Def () $ switchToWorkspace idx+ return True++instance WorkspaceWidgetController WorkspaceButtonController+ where+ getWidget wbc = Gtk.toWidget $ button wbc+ updateWidget wbc update = do+ newContents <- updateWidget (contentsController wbc) update+ return wbc { contentsController = newContents }++data WorkspaceUnderlineController = WorkspaceUnderlineController+ { table :: T.Table+ -- XXX: An event box is used here because we need to change the background+ , underline :: Gtk.EventBox+ , overlineController :: WWC+ }++buildUnderlineController :: ParentControllerConstructor+buildUnderlineController contentsBuilder workspace = do+ cfg <- asks hudConfig+ cc <- contentsBuilder workspace++ lift $ do+ t <- T.tableNew 2 1 False+ u <- Gtk.eventBoxNew+ W.widgetSetSizeRequest u (-1) $ underlineHeight cfg++ T.tableAttach t (getWidget cc) 0 1 0 1+ [T.Expand, T.Fill] [T.Expand, T.Fill] 0 0+ T.tableAttach t u 0 1 1 2+ [T.Fill] [T.Shrink] (underlinePadding cfg) 0++ _ <- widgetSetClass u "Underline"+ return $ WWC WorkspaceUnderlineController+ {table = t, underline = u, overlineController = cc}++instance WorkspaceWidgetController WorkspaceUnderlineController where+ getWidget uc = Gtk.toWidget $ table uc+ updateWidget uc wu@(WorkspaceUpdate workspace) =+ lift (setWorkspaceWidgetStatusClass workspace (underline uc)) >>+ updateUnderline uc wu+ updateWidget a b = updateUnderline a b++updateUnderline :: WorkspaceUnderlineController+ -> WidgetUpdate+ -> WorkspacesIO WorkspaceUnderlineController+updateUnderline uc u = do+ newContents <- updateWidget (overlineController uc) u+ return uc { overlineController = newContents }++data WorkspaceBorderController =+ WorkspaceBorderController { border :: Gtk.EventBox+ , borderContents :: Gtk.EventBox+ , insideController :: WWC+ }++buildBorderController :: ParentControllerConstructor+buildBorderController contentsBuilder workspace = do+ cc <- contentsBuilder workspace+ cfg <- asks hudConfig+ lift $ do+ brd <- Gtk.eventBoxNew+ cnt <- Gtk.eventBoxNew+ Gtk.eventBoxSetVisibleWindow brd True+ Gtk.containerSetBorderWidth cnt $ borderWidth cfg+ Gtk.containerAdd brd cnt+ Gtk.containerAdd cnt $ getWidget cc+ _ <- widgetSetClass brd "Border"+ _ <- widgetSetClass cnt "Container"+ return $+ WWC+ WorkspaceBorderController+ {border = brd, borderContents = cnt, insideController = cc}++instance WorkspaceWidgetController WorkspaceBorderController where+ getWidget bc = Gtk.toWidget $ border bc+ updateWidget bc wu@(WorkspaceUpdate workspace) =+ let setClasses = setWorkspaceWidgetStatusClass workspace+ in lift (setClasses (border bc) >> setClasses (borderContents bc)) >>+ updateBorder bc wu+ updateWidget a b = updateBorder a b++updateBorder :: WorkspaceBorderController+ -> WidgetUpdate+ -> WorkspacesIO WorkspaceBorderController+updateBorder bc update = do+ newContents <- updateWidget (insideController bc) update+ return bc { insideController = newContents }++buildUnderlineButtonController :: ControllerConstructor+buildUnderlineButtonController =+ buildButtonController (buildUnderlineController defaultBuildContentsController)++buildBorderButtonController :: ControllerConstructor+buildBorderButtonController =+ buildButtonController (buildBorderController defaultBuildContentsController)
+ src/System/Taffybar/Widget/XDGMenu/Menu.hs view
@@ -0,0 +1,136 @@+-----------------------------------------------------------------------------+-- |+-- Module : System.Taffybar.Widget.XDGMenu.Menu+-- Copyright : 2017 Ulf Jasper+-- License : BSD3-style (see LICENSE)+--+-- Maintainer : Ulf Jasper <ulf.jasper@web.de>+-- Stability : unstable+-- Portability : unportable+--+-- Implementation of version 1.1 of the freedesktop "Desktop Menu+-- Specification", see+-- https://specifications.freedesktop.org/menu-spec/menu-spec-1.1.html+--+-- See also 'MenuWidget'.+-----------------------------------------------------------------------------++module System.Taffybar.Widget.XDGMenu.Menu+ ( Menu(..)+ , MenuEntry(..)+ , buildMenu+ , getApplicationEntries+ ) where++import Data.Char (toLower)+import Data.List+import Data.Maybe+import System.Taffybar.Information.XDG.DesktopEntry+import System.Taffybar.Information.XDG.Protocol++-- | Displayable menu+data Menu = Menu+ { fmName :: String+ , fmComment :: String+ , fmIcon :: Maybe String+ , fmSubmenus :: [Menu]+ , fmEntries :: [MenuEntry]+ , fmOnlyUnallocated :: Bool+ } deriving (Show)++-- | Displayable menu entry+data MenuEntry = MenuEntry+ { feName :: String+ , feComment :: String+ , feCommand :: String+ , feIcon :: Maybe String+ } deriving (Eq, Show)++-- | Fetch menus and desktop entries and assemble the menu.+buildMenu :: Maybe String -> IO Menu+buildMenu mMenuPrefix = do+ mMenuDes <- readXDGMenu mMenuPrefix+ case mMenuDes of+ Nothing -> return $ Menu "???" "Parsing failed" Nothing [] [] False+ Just (menu, des) -> do+ dt <- getXDGDesktop+ dirDirs <- getDirectoryDirs+ langs <- getPreferredLanguages+ (fm, ae) <- xdgToMenu dt langs dirDirs des menu+ let fm' = fixOnlyUnallocated ae fm+ return fm'++-- | Convert xdg menu to displayable menu+xdgToMenu+ :: String+ -> [String]+ -> [FilePath]+ -> [DesktopEntry]+ -> XDGMenu+ -> IO (Menu, [MenuEntry])+xdgToMenu desktop langs dirDirs des xm = do+ dirEntry <- getDirectoryEntry dirDirs (xmDirectory xm)+ mas <- mapM (xdgToMenu desktop langs dirDirs des) (xmSubmenus xm)+ let (menus, subaes) = unzip mas+ menus' = sortBy (\fm1 fm2 -> compare (map toLower $ fmName fm1)+ (map toLower $ fmName fm2)) menus+ entries = map (xdgToMenuEntry langs) $+ -- hide NoDisplay+ filter (not . deNoDisplay) $+ -- onlyshowin+ filter (matchesOnlyShowIn desktop) $+ -- excludes+ filter (not . flip matchesCondition (fromMaybe None (xmExclude xm))) $+ -- includes+ filter (`matchesCondition` fromMaybe None (xmInclude xm)) des+ onlyUnallocated = xmOnlyUnallocated xm+ aes = if onlyUnallocated then [] else entries ++ concat subaes+ let fm = Menu {fmName = maybe (xmName xm) (deName langs) dirEntry,+ fmComment = maybe "???" (fromMaybe "???" . deComment langs) dirEntry,+ fmIcon = deIcon =<< dirEntry,+ fmSubmenus = menus',+ fmEntries = entries,+ fmOnlyUnallocated = onlyUnallocated}+ return (fm, aes)++-- | Check the "only show in" logic+matchesOnlyShowIn :: String -> DesktopEntry -> Bool+matchesOnlyShowIn desktop de = matchesShowIn && notMatchesNotShowIn+ where matchesShowIn = case deOnlyShowIn de of+ [] -> True+ desktops -> desktop `elem` desktops+ notMatchesNotShowIn = case deNotShowIn de of+ [] -> True+ desktops -> desktop `notElem` desktops++-- | convert xdg desktop entry to displayble menu entry+xdgToMenuEntry :: [String] -> DesktopEntry -> MenuEntry+xdgToMenuEntry langs de =+ MenuEntry+ {feName = name, feComment = comment, feCommand = cmd, feIcon = mIcon}+ where+ mc =+ case deCommand de of+ Nothing -> Nothing+ Just c -> Just $ "(" ++ c ++ ")"+ comment =+ fromMaybe "??" $+ case deComment langs de of+ Nothing -> mc+ Just tt -> Just $ tt ++ maybe "" ("\n" ++) mc+ cmd = fromMaybe "FIXME" $ deCommand de+ name = deName langs de+ mIcon = deIcon de++-- | postprocess unallocated entries+fixOnlyUnallocated :: [MenuEntry] -> Menu -> Menu+fixOnlyUnallocated fes fm =+ fm+ { fmEntries = entries+ , fmSubmenus = map (fixOnlyUnallocated fes) (fmSubmenus fm)+ }+ where+ entries =+ if fmOnlyUnallocated fm+ then filter (not . (`elem` fes)) (fmEntries fm)+ else fmEntries fm
+ src/System/Taffybar/Widget/XDGMenu/MenuWidget.hs view
@@ -0,0 +1,132 @@+-----------------------------------------------------------------------------+-- |+-- Module : System.Taffybar.Widget.XDGMenu.MenuWidget+-- Copyright : 2017 Ulf Jasper+-- License : BSD3-style (see LICENSE)+--+-- Maintainer : Ulf Jasper <ulf.jasper@web.de>+-- Stability : unstable+-- Portability : unportable+--+-- MenuWidget provides a hierachical GTK menu containing all+-- applicable desktop entries found on the system. The menu is built+-- according to the version 1.1 of the XDG "Desktop Menu+-- Specification", see+-- https://specifications.freedesktop.org/menu-spec/menu-spec-1.1.html+-----------------------------------------------------------------------------++module System.Taffybar.Widget.XDGMenu.MenuWidget+ (+ -- * Usage+ -- $usage+ menuWidgetNew+ )+where++import Control.Monad+import Graphics.UI.Gtk hiding (Menu)+import System.Directory+import System.FilePath.Posix+import System.Process+import System.Taffybar.Widget.XDGMenu.Menu++-- $usage+--+-- In order to use this widget add the following line to your+-- @taffybar.hs@ file:+--+-- > import System.Taffybar.Widget.XDGMenu.MenuWidget+-- > main = do+-- > let menu = menuWidgetNew $ Just "PREFIX-"+--+-- The menu will look for a file named "PREFIX-applications.menu" in+-- the (subdirectory "menus" of the) directories specified by the+-- environment variable XDG_CONFIG_DIRS and "/etc/xdg". If no prefix+-- is given (i.e. if you pass Nothing) then the value of the+-- environment variable XDG_MENU_PREFIX is used, if it is set. If+-- taffybar is running inside a desktop environment like Mate, Gnome,+-- XFCE etc. the environment variables XDG_CONFIG_DIRS and+-- XDG_MENU_PREFIX should be set and you may create the menu like this:+--+-- > let menu = menuWidgetNew Nothing+--+-- Now you can use @menu@ as any other Taffybar widget.+++-- | Add a desktop entry to a gtk menu by appending a gtk menu item.+addItem :: (MenuShellClass msc) =>+ msc -- ^ GTK menu+ -> MenuEntry -- ^ Desktop entry+ -> IO ()+addItem ms de = do+ item <- imageMenuItemNewWithLabel (feName de)+ set item [ widgetTooltipText := Just (feComment de)]+ setIcon item (feIcon de)+ menuShellAppend ms item+ _ <- on item menuItemActivated $ do+ let cmd = feCommand de+ putStrLn $ "Launching '" ++ cmd ++ "'"+ _ <- spawnCommand cmd+ return ()+ return ()++-- | Add an xdg menu to a gtk menu by appending gtk menu items and+-- submenus.+addMenu :: (MenuShellClass msc) =>+ msc -- ^ GTK menu+ -> Menu -- ^ menu+ -> IO ()+addMenu ms fm = do+ let subMenus = fmSubmenus fm+ items = fmEntries fm+ when (not (null items) || not (null subMenus)) $ do+ item <- imageMenuItemNewWithLabel (fmName fm)+ setIcon item (fmIcon fm)+ menuShellAppend ms item+ subMenu <- menuNew+ menuItemSetSubmenu item subMenu+ mapM_ (addMenu subMenu) subMenus+ mapM_ (addItem subMenu) items++setIcon :: ImageMenuItem -> Maybe String -> IO ()+setIcon _ Nothing = return ()+setIcon item (Just iconName) = do+ iconTheme <- iconThemeGetDefault+ hasIcon <- iconThemeHasIcon iconTheme iconName+ mImg <- if hasIcon+ then Just <$> imageNewFromIconName iconName IconSizeMenu+ else if isAbsolute iconName+ then+ do+ ex <- doesFileExist iconName+ if ex+ then do let defaultSize = 24 -- FIXME should auto-adjust to font size+ pb <- pixbufNewFromFileAtScale iconName+ defaultSize defaultSize True+ Just <$> imageNewFromPixbuf pb+ else return Nothing+ else return Nothing+ case mImg of+ Just img -> imageMenuItemSetImage item img+ Nothing -> putStrLn $ "Icon not found: " ++ iconName++-- | Create a new XDG Menu Widget.+menuWidgetNew :: Maybe String -- ^ menu name, must end with a dash,+ -- e.g. "mate-" or "gnome-"+ -> IO Widget+menuWidgetNew mMenuPrefix = do+ mb <- menuBarNew+ m <- buildMenu mMenuPrefix+ addMenu mb m+ widgetShowAll mb+ return (toWidget mb)++-- -- | Show XDG Menu Widget in a standalone frame.+-- testMenuWidget :: IO ()+-- testMenuWidget = do+-- _ <- initGUI+-- window <- windowNew+-- _ <- window `on` deleteEvent $ liftIO mainQuit >> return False+-- containerAdd window =<< menuWidgetNew Nothing+-- widgetShowAll window+-- mainGUI
− src/System/Taffybar/Widgets/Graph.hs
@@ -1,242 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}--- | This is a graph widget inspired by the widget of the same name in--- Awesome (the window manager). It plots a series of data points--- similarly to a bar graph. This version must be explicitly fed data--- with 'graphAddSample'. For a more automated version, see--- 'PollingGraph'.------ Like Awesome, this graph can plot multiple data sets in one widget.--- The data sets are plotted in the order provided by the caller.------ Note: all of the data fed to this widget should be in the range--- [0,1].-module System.Taffybar.Widgets.Graph (- -- * Types- GraphHandle- , GraphConfig(..)- , GraphDirection(..)- , GraphStyle(..)- -- * Functions- , graphNew- , graphAddSample- , defaultGraphConfig- ) where--import System.Taffybar.Widgets.Util-import Prelude hiding ( mapM_ )-import Control.Concurrent-import Data.Sequence ( Seq, (<|), viewl, ViewL(..) )-import Data.Foldable ( mapM_ )-import Control.Monad ( when )-import Control.Monad.Trans ( liftIO )-import qualified Data.Sequence as S-import qualified Graphics.Rendering.Cairo as C-import qualified Graphics.Rendering.Cairo.Matrix as M-import qualified Graphics.UI.Gtk as Gtk--newtype GraphHandle = GH (MVar GraphState)-data GraphState =- GraphState { graphIsBootstrapped :: Bool- , graphHistory :: [Seq Double]- , graphCanvas :: Gtk.DrawingArea- , graphConfig :: GraphConfig- }--data GraphDirection = LEFT_TO_RIGHT | RIGHT_TO_LEFT deriving (Eq)---- | The style of the graph. Generally, you will want to draw all 'Area' graphs first, and then all 'Line' graphs.-data GraphStyle- = Area -- ^ Thea area below the value is filled- | Line -- ^ The values are connected by a line (one pixel wide)---- | The configuration options for the graph. The padding is the--- number of pixels reserved as blank space around the widget in each--- direction.-data GraphConfig = GraphConfig {- -- | Number of pixels of padding on each side of the graph widget- graphPadding :: Int- -- | The background color of the graph (default black)- , graphBackgroundColor :: (Double, Double, Double)- -- | The border color drawn around the graph (default gray)- , graphBorderColor :: (Double, Double, Double)- -- | The width of the border (default 1, use 0 to disable the border)- , graphBorderWidth :: Int- -- | Colors for each data set (default cycles between red, green and blue)- , graphDataColors :: [(Double, Double, Double, Double)]- -- | How to draw each data point (default @repeat Area@)- , graphDataStyles :: [GraphStyle]- -- | The number of data points to retain for each data set (default 20)- , graphHistorySize :: Int- -- | May contain Pango markup (default @Nothing@)- , graphLabel :: Maybe String- -- | The width (in pixels) of the graph widget (default 50)- , graphWidth :: Int- -- | The direction in which the graph will move as time passes (default LEFT_TO_RIGHT)- , graphDirection :: GraphDirection- }--defaultGraphConfig :: GraphConfig-defaultGraphConfig =- GraphConfig- { graphPadding = 2- , graphBackgroundColor = (0.0, 0.0, 0.0)- , graphBorderColor = (0.5, 0.5, 0.5)- , graphBorderWidth = 1- , graphDataColors = cycle [(1, 0, 0, 0), (0, 1, 0, 0), (0, 0, 1, 0)]- , graphDataStyles = repeat Area- , graphHistorySize = 20- , graphLabel = Nothing- , graphWidth = 50- , graphDirection = LEFT_TO_RIGHT- }---- | Add a data point to the graph for each of the tracked data sets.--- There should be as many values in the list as there are data sets.-graphAddSample :: GraphHandle -> [Double] -> IO ()-graphAddSample (GH mv) rawData = do- s <- readMVar mv- let drawArea = graphCanvas s- histSize = graphHistorySize (graphConfig s)- histsAndNewVals = zip pcts (graphHistory s)- newHists = case graphHistory s of- [] -> map S.singleton pcts- _ -> map (\(p,h) -> S.take histSize $ p <| h) histsAndNewVals- case graphIsBootstrapped s of- False -> return ()- True -> do- modifyMVar_ mv (\s' -> return s' { graphHistory = newHists })- Gtk.postGUIAsync $ Gtk.widgetQueueDraw drawArea- where- pcts = map (clamp 0 1) rawData--clamp :: Double -> Double -> Double -> Double-clamp lo hi d = max lo $ min hi d--outlineData :: (Double -> Double) -> Double -> Double -> C.Render ()-outlineData pctToY xStep pct = do- (curX,_) <- C.getCurrentPoint- C.lineTo (curX + xStep) (pctToY pct)--renderFrameAndBackground :: GraphConfig -> Int -> Int -> C.Render ()-renderFrameAndBackground cfg w h = do- let (backR, backG, backB) = graphBackgroundColor cfg- (frameR, frameG, frameB) = graphBorderColor cfg- pad = graphPadding cfg- fpad = fromIntegral pad- fw = fromIntegral w- fh = fromIntegral h-- -- Draw the requested background- C.setSourceRGB backR backG backB- C.rectangle fpad fpad (fw - 2 * fpad) (fh - 2 * fpad)- C.fill-- -- Draw a frame around the widget area- -- (unless equal to background color, which likely means the user does not- -- want a frame)- when (graphBorderWidth cfg > 0) $ do- let p = fromIntegral (graphBorderWidth cfg)- C.setLineWidth p- C.setSourceRGB frameR frameG frameB- C.rectangle (fpad + (p / 2)) (fpad + (p / 2)) (fw - 2 * fpad - p) (fh - 2 * fpad - p)- C.stroke---renderGraph :: [Seq Double] -> GraphConfig -> Int -> Int -> Double -> C.Render ()-renderGraph hists cfg w h xStep = do- renderFrameAndBackground cfg w h-- C.setLineWidth 0.1-- let pad = fromIntegral $ graphPadding cfg- let framePad = fromIntegral $ graphBorderWidth cfg-- -- Make the new origin be inside the frame and then scale the- -- drawing area so that all operations in terms of width and height- -- are inside the drawn frame.- C.translate (pad + framePad) (pad + framePad)- let xS = (fromIntegral w - 2 * pad - 2 * framePad) / fromIntegral w- yS = (fromIntegral h - 2 * pad - 2 * framePad) / fromIntegral h- C.scale xS yS-- -- If right-to-left direction is requested, apply an horizontal inversion- -- transformation with an offset to the right equal to the width of the widget.- if graphDirection cfg == RIGHT_TO_LEFT- then C.transform $ M.Matrix (-1) 0 0 1 (fromIntegral w) 0- else return ()-- let pctToY pct = fromIntegral h * (1 - pct)- renderDataSet hist color style- | S.length hist <= 1 = return ()- | otherwise = do- let (r, g, b, a) = color- originY = pctToY newestSample- originX = 0- newestSample :< hist' = viewl hist- C.setSourceRGBA r g b a- C.moveTo originX originY-- mapM_ (outlineData pctToY xStep) hist'- case style of- Area -> do- (endX, _) <- C.getCurrentPoint- C.lineTo endX (fromIntegral h)- C.lineTo 0 (fromIntegral h)- C.fill- Line -> do- C.setLineWidth 1.0- C.stroke--- sequence_ $ zipWith3 renderDataSet hists (graphDataColors cfg) (graphDataStyles cfg)--drawBorder :: MVar GraphState -> Gtk.DrawingArea -> C.Render ()-drawBorder mv drawArea = do- (w, h) <- widgetGetAllocatedSize drawArea- s <- liftIO $ readMVar mv- let cfg = graphConfig s- renderFrameAndBackground cfg w h- liftIO $ modifyMVar_ mv (\s' -> return s' { graphIsBootstrapped = True })- return ()--drawGraph :: MVar GraphState -> Gtk.DrawingArea -> C.Render ()-drawGraph mv drawArea = do- (w, h) <- widgetGetAllocatedSize drawArea- drawBorder mv drawArea- s <- liftIO $ readMVar mv- let hist = graphHistory s- cfg = graphConfig s- histSize = graphHistorySize cfg- -- Subtract 1 here since the first data point doesn't require- -- any movement in the X direction- xStep = fromIntegral w / fromIntegral (histSize - 1)-- case hist of- [] -> renderFrameAndBackground cfg w h- _ -> renderGraph hist cfg w h xStep--graphNew :: GraphConfig -> IO (Gtk.Widget, GraphHandle)-graphNew cfg = do- drawArea <- Gtk.drawingAreaNew- mv <- newMVar GraphState { graphIsBootstrapped = False- , graphHistory = []- , graphCanvas = drawArea- , graphConfig = cfg- }-- Gtk.widgetSetSizeRequest drawArea (graphWidth cfg) (-1)- _ <- Gtk.on drawArea Gtk.draw $ drawGraph mv drawArea- box <- Gtk.hBoxNew False 1-- case graphLabel cfg of- Nothing -> return ()- Just lbl -> do- l <- Gtk.labelNew (Nothing :: Maybe String)- Gtk.labelSetMarkup l lbl- Gtk.boxPackStart box l Gtk.PackNatural 0-- Gtk.set drawArea [Gtk.widgetVExpand Gtk.:= True]- Gtk.set box [Gtk.widgetVExpand Gtk.:= True]- Gtk.boxPackStart box drawArea Gtk.PackGrow 0- Gtk.widgetShowAll box- return (Gtk.toWidget box, GH mv)
− src/System/Taffybar/Widgets/Icon.hs
@@ -1,58 +0,0 @@--- | This is a simple static image widget, and a polling image widget that--- updates its contents by calling a callback at a set interval.-module System.Taffybar.Widgets.Icon-(- iconImageWidgetNew,- pollingIconImageWidgetNew-) where--import Control.Concurrent ( forkIO, threadDelay )-import Control.Exception as E-import Control.Monad ( forever )-import Graphics.UI.Gtk---- | Create a new widget that displays a static image------ > iconImageWidgetNew path------ returns a widget with icon at @path@.-iconImageWidgetNew :: FilePath -> IO Widget-iconImageWidgetNew path = do- box <- hBoxNew False 0- icon <- imageNewFromFile path- boxPackStart box icon PackNatural 0- widgetShowAll box- return $ toWidget box---- | Create a new widget that updates itself at regular intervals. The--- function------ > pollingIconImageWidgetNew path interval cmd------ returns a widget with initial icon at @path@. The widget--- forks a thread to update its contents every @interval@ seconds.--- The command should return a FilePath of a valid icon.------ If the IO action throws an exception, it will be swallowed and the--- label will not update until the update interval expires.-pollingIconImageWidgetNew :: FilePath -- ^ Initial file path of the icon- -> Double -- ^ Update interval (in seconds)- -> IO FilePath -- ^ Command to run to get the input filepath- -> IO Widget-pollingIconImageWidgetNew path interval cmd = do- box <- hBoxNew False 0- icon <- imageNewFromFile path- _ <- on icon realize $ do- _ <- forkIO $ forever $ do- let tryUpdate = do- str <- cmd- postGUIAsync $ imageSetFromFile icon str- E.catch tryUpdate ignoreIOException- threadDelay $ floor (interval * 1000000)- return ()- boxPackStart box icon PackNatural 0- widgetShowAll box- return $ toWidget box--ignoreIOException :: IOException -> IO ()-ignoreIOException _ = return ()
− src/System/Taffybar/Widgets/PollingBar.hs
@@ -1,33 +0,0 @@--- | Like the vertical bar, but this widget automatically updates--- itself with a callback at fixed intervals.-module System.Taffybar.Widgets.PollingBar (- -- * Types- VerticalBarHandle,- BarConfig(..),- BarDirection(..),- -- * Constructors and accessors- pollingBarNew,- defaultBarConfig- ) where--import Control.Concurrent-import qualified Control.Exception.Enclosed as E-import Control.Monad ( forever )-import Graphics.UI.Gtk--import System.Taffybar.Widgets.VerticalBar--pollingBarNew :: BarConfig -> Double -> IO Double -> IO Widget-pollingBarNew cfg pollSeconds action = do- (drawArea, h) <- verticalBarNew cfg-- _ <- on drawArea realize $ do- _ <- forkIO $ forever $ do- esample <- E.tryAny action- case esample of- Left _ -> return ()- Right sample -> verticalBarSetPercent h sample- threadDelay $ floor (pollSeconds * 1000000)- return ()-- return drawArea
− src/System/Taffybar/Widgets/PollingGraph.hs
@@ -1,37 +0,0 @@--- | A variant of the Graph widget that automatically updates itself--- with a callback at a fixed interval.-module System.Taffybar.Widgets.PollingGraph (- -- * Types- GraphHandle,- GraphConfig(..),- GraphDirection(..),- GraphStyle(..),- -- * Constructors and accessors- pollingGraphNew,- defaultGraphConfig- ) where--import Control.Concurrent-import qualified Control.Exception.Enclosed as E-import Control.Monad ( forever )-import Graphics.UI.Gtk--import System.Taffybar.Widgets.Graph--pollingGraphNew :: GraphConfig- -> Double- -> IO [Double]- -> IO Widget-pollingGraphNew cfg pollSeconds action = do- (da, h) <- graphNew cfg-- _ <- on da realize $ do- _ <- forkIO $ forever $ do- esample <- E.tryAny action- case esample of- Left _ -> return ()- Right sample -> graphAddSample h sample- threadDelay $ floor (pollSeconds * 1000000)- return ()-- return da
− src/System/Taffybar/Widgets/PollingLabel.hs
@@ -1,64 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}--- | This is a simple text widget that updates its contents by calling--- a callback at a set interval.-module System.Taffybar.Widgets.PollingLabel ( pollingLabelNew,- pollingLabelNewWithTooltip) where--import Control.Concurrent ( forkIO, threadDelay )-import Control.Exception.Enclosed as E-import Control.Monad ( forever )-import Graphics.UI.Gtk---- | Create a new widget that updates itself at regular intervals. The--- function------ > pollingLabelNew initialString cmd interval------ returns a widget with initial text @initialString@. The widget--- forks a thread to update its contents every @interval@ seconds.--- The command should return a string with any HTML entities escaped.--- This is not checked by the function, since Pango markup shouldn't--- be escaped. Proper input sanitization is up to the caller.------ If the IO action throws an exception, it will be swallowed and the--- label will not update until the update interval expires.-pollingLabelNew :: String -- ^ Initial value for the label- -> Double -- ^ Update interval (in seconds)- -> IO String -- ^ Command to run to get the input string- -> IO Widget-pollingLabelNew initialString interval cmd = do- l <- labelNew (Nothing :: Maybe String)- labelSetMarkup l initialString-- _ <- on l realize $ do- _ <- forkIO $ forever $ do- estr <- E.tryAny cmd- case estr of- Left _ -> return ()- Right str -> postGUIAsync $ labelSetMarkup l str- threadDelay $ floor (interval * 1000000)- return ()-- return (toWidget l)--pollingLabelNewWithTooltip :: String -- ^ Initial value for the label- -> Double -- ^ Update interval (in seconds)- -> IO (String, Maybe String) -- ^ Command to run to get the input string- -> IO Widget-pollingLabelNewWithTooltip initialString interval cmd = do- l <- labelNew (Nothing :: Maybe String)- labelSetMarkup l initialString-- _ <- on l realize $ do- _ <- forkIO $ forever $ do- estr <- E.tryAny cmd- case estr of- Left _ -> return ()- Right (labelStr, tooltipStr) -> postGUIAsync $ do- labelSetMarkup l labelStr- widgetSetTooltipMarkup l tooltipStr- threadDelay $ floor (interval * 1000000)- return ()-- return (toWidget l)-
− src/System/Taffybar/Widgets/Util.hs
@@ -1,74 +0,0 @@--------------------------------------------------------------------------------- |--- Module : System.Taffybar.Widgets.Util--- Copyright : (c) José A. Romero L.--- License : BSD3-style (see LICENSE)------ Maintainer : José A. Romero L. <escherdragon@gmail.com>--- Stability : unstable--- Portability : unportable------ Utility functions to facilitate building GTK interfaces.-----------------------------------------------------------------------------------module System.Taffybar.Widgets.Util where--import Control.Monad-import Control.Monad.IO.Class-import Data.Tuple.Sequence-import Graphics.UI.Gtk-import Prelude---- | Execute the given action as a response to any of the given types--- of mouse button clicks.-onClick :: [Click] -- ^ Types of button clicks to listen to.- -> IO a -- ^ Action to execute.- -> EventM EButton Bool-onClick triggers action = tryEvent $ do- click <- eventClick- when (click `elem` triggers) $ liftIO action >> return ()---- | Attach the given widget as a popup with the given title to the--- given window. The newly attached popup is not shown initially. Use--- the 'displayPopup' function to display it.-attachPopup :: (WidgetClass w, WindowClass wnd) =>- w -- ^ The widget to set as popup.- -> String -- ^ The title of the popup.- -> wnd -- ^ The window to attach the popup to.- -> IO ()-attachPopup widget title window = do- set window [ windowTitle := title- , windowTypeHint := WindowTypeHintTooltip- , windowSkipTaskbarHint := True- , windowSkipPagerHint := True- , windowTransientFor :=> getWindow- ]- windowSetKeepAbove window True- windowStick window- where getWindow = do- Just topLevelWindow <- (fmap castToWindow) <$> widgetGetAncestor widget gTypeWindow- return topLevelWindow---- | Display the given popup widget (previously prepared using the--- 'attachPopup' function) immediately beneath (or above) the given--- window.-displayPopup :: (WidgetClass w, WindowClass wnd) =>- w -- ^ The popup widget.- -> wnd -- ^ The window the widget was attached to.- -> IO ()-displayPopup widget window = do- windowSetPosition window WinPosMouse- (x, y ) <- windowGetPosition window- (_, y') <- widgetGetSizeRequest widget- widgetShowAll window- if y > y'- then windowMove window x (y - y')- else windowMove window x y'--widgetGetAllocatedSize- :: (WidgetClass self, MonadIO m)- => self -> m (Int, Int)-widgetGetAllocatedSize widget =- liftIO $- sequenceT (widgetGetAllocatedWidth widget, widgetGetAllocatedHeight widget)
− src/System/Taffybar/Widgets/VerticalBar.hs
@@ -1,179 +0,0 @@--- | A vertical bar that can plot data in the range [0, 1]. The--- colors are configurable.-module System.Taffybar.Widgets.VerticalBar (- -- * Types- VerticalBarHandle,- BarConfig(..),- BarDirection(..),- -- * Accessors/Constructors- verticalBarNew,- verticalBarSetPercent,- defaultBarConfig,- defaultBarConfigIO- ) where--import Control.Concurrent-import Control.Monad.Trans-import qualified Graphics.Rendering.Cairo as C-import Graphics.UI.Gtk-import System.Taffybar.Widgets.Util--newtype VerticalBarHandle = VBH (MVar VerticalBarState)-data VerticalBarState = VerticalBarState- { barIsBootstrapped :: Bool- , barPercent :: Double- , barCanvas :: DrawingArea- , barConfig :: BarConfig- }--data BarDirection = HORIZONTAL | VERTICAL--data BarConfig- = BarConfig {- -- | Color of the border drawn around the widget- barBorderColor :: (Double, Double, Double)- -- | The background color of the widget- , barBackgroundColor :: Double -> (Double, Double, Double)- -- | A function to determine the color of the widget for the current data point- , barColor :: Double -> (Double, Double, Double)- -- | Number of pixels of padding around the widget- , barPadding :: Int- , barWidth :: Int- , barDirection :: BarDirection}- | BarConfigIO { barBorderColorIO :: IO (Double, Double, Double)- , barBackgroundColorIO :: Double -> IO (Double, Double, Double)- , barColorIO :: Double -> IO (Double, Double, Double)- , barPadding :: Int- , barWidth :: Int- , barDirection :: BarDirection}---- | A default bar configuration. The color of the active portion of--- the bar must be specified.-defaultBarConfig :: (Double -> (Double, Double, Double)) -> BarConfig-defaultBarConfig c =- BarConfig- { barBorderColor = (0.5, 0.5, 0.5)- , barBackgroundColor = const (0, 0, 0)- , barColor = c- , barPadding = 2- , barWidth = 15- , barDirection = VERTICAL- }--defaultBarConfigIO :: (Double -> IO (Double, Double, Double)) -> BarConfig-defaultBarConfigIO c =- BarConfigIO- { barBorderColorIO = return (0.5, 0.5, 0.5)- , barBackgroundColorIO = \_ -> return (0, 0, 0)- , barColorIO = c- , barPadding = 2- , barWidth = 15- , barDirection = VERTICAL- }--verticalBarSetPercent :: VerticalBarHandle -> Double -> IO ()-verticalBarSetPercent (VBH mv) pct = do- s <- readMVar mv- let drawArea = barCanvas s- case barIsBootstrapped s of- False -> return ()- True -> do- modifyMVar_ mv (\s' -> return s' { barPercent = clamp 0 1 pct })- postGUIAsync $ widgetQueueDraw drawArea--clamp :: Double -> Double -> Double -> Double-clamp lo hi d = max lo $ min hi d--liftedBackgroundColor :: BarConfig -> Double -> IO (Double, Double, Double)-liftedBackgroundColor bc pct =- case bc of- BarConfig { barBackgroundColor = bcolor } -> return (bcolor pct)- BarConfigIO { barBackgroundColorIO = bcolor } -> bcolor pct--liftedBorderColor :: BarConfig -> IO (Double, Double, Double)-liftedBorderColor bc =- case bc of- BarConfig { barBorderColor = border } -> return border- BarConfigIO { barBorderColorIO = border } -> border--liftedBarColor :: BarConfig -> Double -> IO (Double, Double, Double)-liftedBarColor bc pct =- case bc of- BarConfig { barColor = c } -> return (c pct)- BarConfigIO { barColorIO = c } -> c pct--renderFrame :: Double -> BarConfig -> Int -> Int -> C.Render ()-renderFrame pct cfg width height = do- let fwidth = fromIntegral width- fheight = fromIntegral height-- -- Now draw the user's requested background, respecting padding- (bgR, bgG, bgB) <- C.liftIO $ liftedBackgroundColor cfg pct- let pad = barPadding cfg- fpad = fromIntegral pad- C.setSourceRGB bgR bgG bgB- C.rectangle fpad fpad (fwidth - 2 * fpad) (fheight - 2 * fpad)- C.fill-- -- Now draw a nice frame- (frameR, frameG, frameB) <- C.liftIO $ liftedBorderColor cfg- C.setSourceRGB frameR frameG frameB- C.setLineWidth 1.0- C.rectangle (fpad + 0.5) (fpad + 0.5) (fwidth - 2 * fpad - 1) (fheight - 2 * fpad - 1)- C.stroke--renderBar :: Double -> BarConfig -> Int -> Int -> C.Render ()-renderBar pct cfg width height = do- let direction = barDirection cfg- activeHeight = case direction of- VERTICAL -> pct * (fromIntegral height)- HORIZONTAL -> fromIntegral height- activeWidth = case direction of- VERTICAL -> fromIntegral width- HORIZONTAL -> pct * (fromIntegral width)- newOrigin = case direction of- VERTICAL -> fromIntegral height - activeHeight- HORIZONTAL -> 0- pad = barPadding cfg-- renderFrame pct cfg width height-- -- After we draw the frame, transform the coordinate space so that- -- we only draw within the frame.- C.translate (fromIntegral pad + 1) (fromIntegral pad + 1)- let xS = fromIntegral (width - 2 * pad - 2) / fromIntegral width- yS = fromIntegral (height - 2 * pad - 2) / fromIntegral height- C.scale xS yS-- (r, g, b) <- C.liftIO $ liftedBarColor cfg pct- C.setSourceRGB r g b- C.translate 0 newOrigin- C.rectangle 0 0 activeWidth activeHeight- C.fill--drawBar :: MVar VerticalBarState -> DrawingArea -> C.Render ()-drawBar mv drawArea = do- (w, h) <- widgetGetAllocatedSize drawArea- s <- liftIO $ do- s <- readMVar mv- modifyMVar_ mv (\s' -> return s' { barIsBootstrapped = True })- return s- renderBar (barPercent s) (barConfig s) w h--verticalBarNew :: BarConfig -> IO (Widget, VerticalBarHandle)-verticalBarNew cfg = do- drawArea <- drawingAreaNew- mv <-- newMVar- VerticalBarState- { barIsBootstrapped = False- , barPercent = 0- , barCanvas = drawArea- , barConfig = cfg- }- widgetSetSizeRequest drawArea (barWidth cfg) (-1)- _ <- on drawArea draw $ drawBar mv drawArea- box <- hBoxNew False 1- boxPackStart box drawArea PackGrow 0- widgetShowAll box- return (toWidget box, VBH mv)
− src/System/Taffybar/WindowSwitcher.hs
@@ -1,141 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}--------------------------------------------------------------------------------- |--- Module : System.Taffybar.WindowSwitcher--- Copyright : (c) José A. Romero L.--- License : BSD3-style (see LICENSE)------ Maintainer : José A. Romero L. <escherdragon@gmail.com>--- Stability : unstable--- Portability : unportable------ Menu widget that shows the title of the currently focused window and that,--- when clicked, displays the list of all currently open windows allowing to--- switch to any of them.------ 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.WindowSwitcher (- -- * Usage- -- $usage- windowSwitcherNew-) where--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-import System.Taffybar.Pager---- $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--- > ...------ Once you've properly configured @xmonad.hs@, you can use the widget in--- your @taffybar.hs@ file:------ > import System.Taffybar.WindowSwitcher--- > main = do--- > pager <- pagerNew defaultPagerConfig--- > let wnd = windowSwitcherNew pager------ now you can use @wnd@ as any other Taffybar widget.---- | Create a new WindowSwitcher widget that will use the given Pager as--- its source of events.-windowSwitcherNew :: Pager -> IO Gtk.Widget-windowSwitcherNew pager = do- 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- 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--- currently focused window.-pagerCallback :: PagerConfig -> Gtk.Label -> Event -> X11Property ()-pagerCallback cfg label _ = do- title <- getActiveWindowTitle- let decorate = activeWindow cfg- lift $ Gtk.postGUIAsync $ Gtk.labelSetMarkup label (decorate $ nonEmpty title)--assembleWidget :: Pager -> Gtk.Label -> IO Gtk.Widget-assembleWidget pager label = do- ebox <- Gtk.eventBoxNew- Gtk.widgetSetName ebox "WindowTitle"- Gtk.containerAdd ebox label-- title <- Gtk.menuItemNew- Gtk.widgetSetName title "title"- Gtk.containerAdd title ebox-- switcher <- Gtk.menuBarNew- Gtk.widgetSetName switcher "WindowSwitcher"- Gtk.containerAdd switcher title-- menu <- Gtk.menuNew- Gtk.widgetSetName menu "menu"-- menuTop <- Gtk.widgetGetToplevel menu- Gtk.widgetSetName menuTop "Taffybar_WindowSwitcher"-- 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 pager menu- _ <- Gtk.on title Gtk.menuItemDeselect $ emptyMenu menu-- Gtk.widgetShowAll switcher- return $ Gtk.toWidget switcher---- | Populate the given menu widget with the list of all currently open windows.-fillMenu :: Gtk.MenuClass menu => Pager -> menu -> IO ()-fillMenu pager menu =- runWithPager pager $ do- handles <- getWindowHandles- if null handles- then return ()- else do- wsNames <- getWorkspaceNames- forM_ handles $ \handle ->- liftIO $ do- let formatEntry = windowSwitcherFormatter $ config pager- item <-- Gtk.menuItemNewWithLabel (formatEntry (M.fromList wsNames) handle)- _ <-- Gtk.on item Gtk.buttonPressEvent $- liftIO $ do- runWithPager pager $ focusWindow $ snd handle- return True- Gtk.menuShellAppend menu item- Gtk.widgetShow item---- | Remove all contents from the given menu widget.-emptyMenu :: Gtk.MenuClass menu => menu -> IO ()-emptyMenu menu = Gtk.containerForeach menu $ \item ->- Gtk.containerRemove menu item >> Gtk.widgetDestroy item--nonEmpty :: String -> String-nonEmpty x =- case x of- [] -> "(nameless window)"- _ -> x
− src/System/Taffybar/WorkspaceHUD.hs
@@ -1,992 +0,0 @@-{-# OPTIONS_GHC -fno-warn-type-defaults #-}-{-# LANGUAGE ScopedTypeVariables, ExistentialQuantification, RankNTypes #-}--------------------------------------------------------------------------------- |--- Module : System.Taffybar.WorkspaceHUD--- Copyright : (c) Ivan A. Malison--- License : BSD3-style (see LICENSE)------ Maintainer : Ivan A. Malison--- Stability : unstable--- Portability : unportable--------------------------------------------------------------------------------module System.Taffybar.WorkspaceHUD (- Context(..),- ControllerConstructor,- HUDIO,- IconInfo(..),- WWC(..),- WindowData(..),- Workspace(..),- WorkspaceButtonController(..),- WorkspaceContentsController(..),- WorkspaceHUDConfig(..),- WorkspaceState(..),- WorkspaceUnderlineController(..),- WorkspaceWidgetController(..),- IconController(..),- buildBorderButtonController,- buildButtonController,- buildContentsController,- buildIconController,- buildLabelController,- buildPadBox,- buildUnderlineButtonController,- buildUnderlineController,- buildWorkspaceHUD,- buildWorkspaces,- defaultBuildContentsController,- defaultGetIconInfo,- defaultWorkspaceHUDConfig,- getWorkspaceToWindows,- hideEmpty,- hudFromPagerConfig,- liftPager,- liftX11Def,- setImage,- widgetSetClass,- windowTitleClassIconGetter,-) where--import Control.Applicative-import Control.Arrow ((&&&))-import Control.Concurrent-import qualified Control.Concurrent.MVar as MV-import Control.Monad-import Control.Monad.IO.Class-import Control.Monad.Reader-import Control.RateLimit-import qualified Data.Foldable as F-import Data.List (intersect, sortBy)-import qualified Data.Map as M-import Data.Maybe-import qualified Data.MultiMap as MM-import qualified Data.Set as Set-import Data.Time.Units-import Data.Tuple.Select-import Data.Tuple.Sequence-import qualified Graphics.UI.Gtk as Gtk-import qualified Graphics.UI.Gtk.Abstract.Widget as W-import Graphics.UI.Gtk.General.StyleContext-import qualified Graphics.UI.Gtk.Layout.Table as T-import Prelude-import System.Information.EWMHDesktopInfo-import System.Information.SafeX11-import System.Information.X11DesktopInfo-import System.Taffybar.IconImages-import System.Taffybar.Pager-import Text.Printf--data WorkspaceState- = Active- | Visible- | Hidden- | Empty- | Urgent- deriving (Show, Eq)--workspaceStates :: [String]-workspaceStates = map show [Active, Visible, Hidden, Empty, Urgent]--data IconInfo- = IIEWMH EWMHIconData- | IIFilePath FilePath- | IIColor ColorRGBA- | IINone- deriving (Eq, Show)--transparentInfo :: IconInfo-transparentInfo = IIColor (0, 0, 0, 0)--data WindowData = WindowData- { windowId :: X11Window- , windowTitle :: String- , windowClass :: String- , windowUrgent :: Bool- , windowActive :: Bool- , windowMinimized :: Bool- } deriving (Show, Eq)--data WidgetUpdate = WorkspaceUpdate Workspace | IconUpdate [X11Window]--data Workspace = Workspace- { workspaceIdx :: WorkspaceIdx- , workspaceName :: String- , workspaceState :: WorkspaceState- , windows :: [WindowData]- } deriving (Show, Eq)--data Context = Context- { controllersVar :: MV.MVar (M.Map WorkspaceIdx WWC)- , workspacesVar :: MV.MVar (M.Map WorkspaceIdx Workspace)- , loggingVar :: MV.MVar Bool- , hudWidget :: Gtk.HBox- , hudConfig :: WorkspaceHUDConfig- , hudPager :: Pager- }--type HUDIO a = ReaderT Context IO a--liftPager :: PagerIO a -> HUDIO a-liftPager action = asks hudPager >>= lift . runReaderT action--liftX11Def :: a -> X11Property a -> HUDIO a-liftX11Def = (liftPager .) . liftPagerX11Def--widgetSetClass- :: W.WidgetClass widget- => widget -> String -> IO ()-widgetSetClass widget klass = do- context <- Gtk.widgetGetStyleContext widget- styleContextAddClass context klass--setWorkspaceWidgetStatusClass- :: W.WidgetClass widget- => Workspace -> widget -> IO ()-setWorkspaceWidgetStatusClass workspace widget =- updateWidgetClasses widget [show $ workspaceState workspace] workspaceStates--updateWidgetClasses- :: W.WidgetClass widget- => widget -> [String] -> [String] -> IO ()-updateWidgetClasses widget toAdd toRemove = do- context <- Gtk.widgetGetStyleContext widget- let hasClass = styleContextHasClass context- addIfMissing klass =- hasClass klass >>= (`when` styleContextAddClass context klass) . not- removeIfPresent klass = unless (klass `elem` toAdd) $- hasClass klass >>= (`when` styleContextRemoveClass context klass)- mapM_ removeIfPresent toRemove- mapM_ addIfMissing toAdd--class WorkspaceWidgetController wc where- getWidget :: wc -> Gtk.Widget- updateWidget :: wc -> WidgetUpdate -> HUDIO wc- updateWidgetX11 :: wc -> WidgetUpdate -> HUDIO wc- updateWidgetX11 cont _ = return cont--data WWC = forall a. WorkspaceWidgetController a => WWC a--instance WorkspaceWidgetController WWC where- getWidget (WWC wc) = getWidget wc- updateWidget (WWC wc) update = WWC <$> updateWidget wc update- updateWidgetX11 (WWC wc) update = WWC <$> updateWidgetX11 wc update--type ControllerConstructor = Workspace -> HUDIO WWC-type ParentControllerConstructor =- ControllerConstructor -> ControllerConstructor--data WorkspaceHUDConfig =- WorkspaceHUDConfig- { widgetBuilder :: ControllerConstructor- , widgetGap :: Int- , windowIconSize :: Int- , underlineHeight :: Int- , minWSWidgetSize :: Maybe Int- , underlinePadding :: Int- , maxIcons :: Maybe Int- , minIcons :: Int- , getIconInfo :: WindowData -> HUDIO IconInfo- , labelSetter :: Workspace -> HUDIO String- , showWorkspaceFn :: Workspace -> Bool- , borderWidth :: Int- , updateEvents :: [String]- , updateRateLimitMicroseconds :: Integer- , debugMode :: Bool- , iconSort :: [WindowData] -> HUDIO [WindowData]- , urgentWorkspaceState :: Bool- }--hudFromPagerConfig :: PagerConfig -> WorkspaceHUDConfig-hudFromPagerConfig pagerConfig =- let updater workspace- | any windowUrgent ws = urgentWorkspace pagerConfig name- | otherwise =- let getter =- case state of- Urgent -> urgentWorkspace- Visible -> visibleWorkspace- Active -> activeWorkspace- Hidden -> hiddenWorkspace- Empty -> emptyWorkspace- in getter pagerConfig name- where- ws = windows workspace- name = workspaceName workspace- state = workspaceState workspace- padded =- if workspacePad pagerConfig- then prefixSpace . updater- else updater- getCustomImage hasIcon wt wc =- case customIcon pagerConfig hasIcon wt wc of- Just fp -> IIFilePath fp- Nothing -> IINone- in defaultWorkspaceHUDConfig- { labelSetter = return . padded- , minIcons =- if fillEmptyImages pagerConfig- then 1- else 0- , maxIcons =- Just $- if useImages pagerConfig- then 1- else 0- , getIconInfo =- windowTitleClassIconGetter- getCustomImage- , widgetGap = workspaceGap pagerConfig- , windowIconSize = imageSize pagerConfig- , widgetBuilder =- if workspaceBorder pagerConfig- then buildBorderButtonController- else buildButtonController defaultBuildContentsController- , minWSWidgetSize = Nothing- , iconSort = return- }- where- prefixSpace "" = ""- prefixSpace s = " " ++ s--windowTitleClassIconGetter- :: (Bool -> String -> String -> IconInfo)- -> (WindowData -> HUDIO IconInfo)-windowTitleClassIconGetter customIconF = fn- where- fn w@WindowData {windowTitle = wTitle, windowClass = wClass} = do- ewmhIcon <- defaultGetIconInfo w- let hasEwmhIcon = ewmhIcon /= IINone- custIcon = customIconF hasEwmhIcon wTitle wClass- hasCustomIcon = custIcon /= IINone- return $ if hasCustomIcon then custIcon else ewmhIcon--defaultWorkspaceHUDConfig :: WorkspaceHUDConfig-defaultWorkspaceHUDConfig =- WorkspaceHUDConfig- { widgetBuilder = buildButtonController defaultBuildContentsController- , widgetGap = 0- , windowIconSize = 16- , underlineHeight = 4- , minWSWidgetSize = Just 30- , underlinePadding = 1- , maxIcons = Nothing- , minIcons = 0- , getIconInfo = defaultGetIconInfo- , labelSetter = return . workspaceName- , showWorkspaceFn = const True- , borderWidth = 2- , iconSort = sortWindowsByPosition- , updateEvents =- [ "WM_HINTS"- , "_NET_CURRENT_DESKTOP"- , "_NET_DESKTOP_NAMES"- , "_NET_NUMBER_OF_DESKTOPS"- , "_NET_WM_DESKTOP"- , "_NET_WM_STATE_HIDDEN"- ]- , updateRateLimitMicroseconds = 100000- , debugMode = False- , urgentWorkspaceState = False- }--hideEmpty :: Workspace -> Bool-hideEmpty Workspace { workspaceState = Empty } = False-hideEmpty _ = True--hudLogger :: Context -> String -> IO ()-hudLogger ctx txt =- do- shouldLog <- MV.readMVar $ loggingVar ctx- when shouldLog $ putStrLn txt--hudLog :: String -> HUDIO ()-hudLog txt = ask >>= lift . flip hudLogger (printf "[WorkspaceHUD] %s" txt)--updateVar :: MV.MVar a -> (a -> HUDIO a) -> HUDIO a-updateVar var modify = do- ctx <- ask- lift $ MV.modifyMVar var $ fmap (\a -> (a, a)) . flip runReaderT ctx . modify--updateWorkspacesVar :: HUDIO (M.Map WorkspaceIdx Workspace)-updateWorkspacesVar = do- workspacesRef <- asks workspacesVar- updateVar workspacesRef buildWorkspaces--getWorkspaceToWindows :: [X11Window] -> X11Property (MM.MultiMap WorkspaceIdx X11Window)-getWorkspaceToWindows =- foldM- (\theMap window ->- MM.insert <$> getWorkspace window <*> pure window <*> pure theMap)- MM.empty--getWindowData :: [X11Window]- -> [X11Window]- -> X11Window- -> X11Property WindowData-getWindowData activeWindows urgentWindows window = do- wTitle <- getWindowTitle window- wClass <- getWindowClass window- wMinimized <- getWindowStateProperty window "_NET_WM_STATE_HIDDEN"- return- WindowData- { windowId = window- , windowTitle = wTitle- , windowClass = wClass- , windowUrgent = window `elem` urgentWindows- , windowActive = window `elem` activeWindows- , windowMinimized = wMinimized- }--buildWorkspaces :: M.Map WorkspaceIdx Workspace- -> HUDIO (M.Map WorkspaceIdx Workspace)-buildWorkspaces _ = ask >>= \context -> liftX11Def M.empty $ do- names <- getWorkspaceNames- wins <- getWindows- workspaceToWindows <- getWorkspaceToWindows wins- urgentWindows <- filterM isWindowUrgent wins- activeWindows <- readAsListOfWindow Nothing "_NET_ACTIVE_WINDOW"- active:visible <- getVisibleWorkspaces- let getWorkspaceState idx ws- | idx == active = Active- | idx `elem` visible = Visible- | urgentWorkspaceState (hudConfig context) &&- not (null (ws `intersect` urgentWindows)) =- Urgent- | null ws = Empty- | otherwise = Hidden- foldM- (\theMap (idx, name) -> do- let ws = MM.lookup idx workspaceToWindows- windowInfos <- mapM (getWindowData activeWindows urgentWindows) ws- return $- M.insert- idx- Workspace- { workspaceIdx = idx- , workspaceName = name- , workspaceState = getWorkspaceState idx ws- , windows = windowInfos- }- theMap)- M.empty- names--addWidgetsToTopLevel :: HUDIO ()-addWidgetsToTopLevel = do- Context { controllersVar = controllersRef- , hudWidget = cont- , hudConfig = cfg- } <- ask- controllersMap <- lift $ MV.readMVar controllersRef- -- Elems returns elements in ascending order of their keys so this will always- -- add the widgets in the correct order- mapM_ addWidget $ M.elems controllersMap- when (debugMode cfg) addDebugWidgets- lift $ Gtk.widgetShowAll cont--addWidget :: WWC -> HUDIO ()-addWidget controller = do- cont <- asks hudWidget- let workspaceWidget = getWidget controller- lift $ do- -- XXX: This hbox exists to (hopefully) prevent the issue where workspace- -- widgets appear out of order, in the switcher, by acting as an empty- -- place holder when the actual widget is hidden.- hbox <- Gtk.hBoxNew False 0- parent <- Gtk.widgetGetParent workspaceWidget- if isJust parent- then Gtk.widgetReparent (getWidget controller) hbox- else Gtk.containerAdd hbox workspaceWidget- Gtk.containerAdd cont hbox--addDebugWidgets :: HUDIO ()-addDebugWidgets = do- ctx <- ask- cont <- asks hudWidget- loggingRef <- asks loggingVar- let getLabelText state = printf "ToggleLogging: %s" $ show state :: String- lift $ do- enableLoggingBox <- Gtk.eventBoxNew- rebuildBarBox <- Gtk.eventBoxNew- Gtk.widgetSetName enableLoggingBox "WorkspaceHUD-toggleLogging"- Gtk.widgetSetName rebuildBarBox "WorkspaceHUD-rebuildButton"- loggingEnabled <- MV.readMVar loggingRef- logLabel <- Gtk.labelNew $ Just $ getLabelText loggingEnabled- rebuildLabel <- Gtk.labelNew $ Just "Rebuild Bar"- Gtk.widgetSetName logLabel "WorkspaceHUD-toggleLogging"- Gtk.widgetSetName rebuildLabel "WorkspaceHUD-rebuildButton"- let toggleLogging =- MV.modifyMVar_- loggingRef- (\current -> do- let newState = not current- labelText = getLabelText newState- Gtk.labelSetMarkup logLabel labelText- return $ not current) >>- return True- -- Clear the container and repopulate it- rebuildBar- = do- Gtk.containerForeach cont (Gtk.containerRemove cont)- runReaderT (addWidgetsToTopLevel >> updateAllWorkspaceWidgets) ctx- return True- Gtk.containerAdd enableLoggingBox logLabel- Gtk.containerAdd rebuildBarBox rebuildLabel- _ <- Gtk.on enableLoggingBox Gtk.buttonPressEvent (liftIO toggleLogging)- _ <- Gtk.on rebuildBarBox Gtk.buttonPressEvent (liftIO rebuildBar)- Gtk.containerAdd cont enableLoggingBox- Gtk.containerAdd cont rebuildBarBox- return ()--buildWorkspaceHUD :: WorkspaceHUDConfig -> Pager -> IO Gtk.Widget-buildWorkspaceHUD cfg pager = do- cont <- Gtk.hBoxNew False (widgetGap cfg)- controllersRef <- MV.newMVar M.empty- workspacesRef <- MV.newMVar M.empty- loggingRef <- MV.newMVar False- let context =- Context- { controllersVar = controllersRef- , workspacesVar = workspacesRef- , loggingVar = loggingRef- , hudWidget = cont- , hudConfig = cfg- , hudPager = pager- }- -- This will actually create all the widgets- runReaderT updateAllWorkspaceWidgets context- updateHandler <- onWorkspaceUpdate context- subscriptions <- mapM (subscribe pager updateHandler) $ updateEvents cfg- iconHandler <- onIconsChanged context- 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 ()-updateAllWorkspaceWidgets = do- hudLog "-Workspace- -Execute-..."-- workspacesMap <- updateWorkspacesVar- hudLog $ printf "Workspaces: %s" $ show workspacesMap-- hudLog "-Workspace- Adding and removing widgets..."- updateWorkspaceControllers-- let updateController' idx controller =- maybe (return controller)- (updateWidget controller . WorkspaceUpdate) $- M.lookup idx workspacesMap- logUpdateController i =- hudLog $ printf "-Workspace- -each- Updating %s widget" $ show i- updateController i cont = logUpdateController i >>- updateController' i cont-- doWidgetUpdate updateController-- hudLog "-Workspace- Showing and hiding controllers..."- setControllerWidgetVisibility--setControllerWidgetVisibility :: HUDIO ()-setControllerWidgetVisibility = do- Context { workspacesVar = workspacesRef- , controllersVar = controllersRef- , hudConfig = cfg- } <- ask- lift $ do- workspacesMap <- MV.readMVar workspacesRef- controllersMap <- MV.readMVar controllersRef- forM_ (M.elems workspacesMap) $ \ws ->- let c = M.lookup (workspaceIdx ws) controllersMap- mWidget = getWidget <$> c- action = if showWorkspaceFn cfg ws- then Gtk.widgetShow- else Gtk.widgetHide- in- maybe (return ()) action mWidget--doWidgetUpdate :: (WorkspaceIdx -> WWC -> HUDIO WWC) -> HUDIO ()-doWidgetUpdate updateController = do- c@Context { controllersVar = controllersRef } <- ask- lift $ MV.modifyMVar_ controllersRef $ \controllers -> do- controllersList <-- mapM- (\(idx, controller) -> do- newController <- runReaderT (updateController idx controller) c- return (idx, newController)) $- M.toList controllers- return $ M.fromList controllersList--updateWorkspaceControllers :: HUDIO ()-updateWorkspaceControllers = do- Context { controllersVar = controllersRef- , workspacesVar = workspacesRef- , hudWidget = cont- , hudConfig = cfg- } <- ask- workspacesMap <- lift $ MV.readMVar workspacesRef- controllersMap <- lift $ MV.readMVar controllersRef-- let newWorkspacesSet = M.keysSet workspacesMap- existingWorkspacesSet = M.keysSet controllersMap-- when (existingWorkspacesSet /= newWorkspacesSet) $ do- let addWorkspaces = Set.difference newWorkspacesSet existingWorkspacesSet- removeWorkspaces = Set.difference existingWorkspacesSet newWorkspacesSet- builder = widgetBuilder cfg-- _ <- updateVar controllersRef $ \controllers -> do- let oldRemoved = F.foldl (flip M.delete) controllers removeWorkspaces- buildController idx = builder <$> M.lookup idx workspacesMap- buildAndAddController theMap idx =- maybe (return theMap) (>>= return . flip (M.insert idx) theMap)- (buildController idx)- foldM buildAndAddController oldRemoved $ Set.toList addWorkspaces- -- Clear the container and repopulate it- lift $ Gtk.containerForeach cont (Gtk.containerRemove cont)- addWidgetsToTopLevel--rateLimitFn- :: forall req resp.- Context- -> (req -> IO resp)- -> ResultsCombiner req resp- -> IO (req -> IO resp)-rateLimitFn context =- let limit = (updateRateLimitMicroseconds $ hudConfig context)- rate = fromMicroseconds limit :: Microsecond in- generateRateLimitedFunction $ PerInvocation rate--onWorkspaceUpdate :: Context -> IO (Event -> IO ())-onWorkspaceUpdate context = do- rateLimited <- rateLimitFn context doUpdate combineRequests- let withLog event = do- case event of- PropertyEvent _ _ _ _ _ atom _ _ ->- hudLogger context $ printf "-Event- -Workspace- %s" $ show atom- _ -> hudLogger context "-Event- -Workspace-"- void $ forkIO $ rateLimited event- return withLog- where- combineRequests _ b = Just (b, const ((), ()))- doUpdate _ = Gtk.postGUIAsync $ runReaderT updateAllWorkspaceWidgets context--onIconChanged :: Context -> (Set.Set X11Window -> IO ()) -> Event -> IO ()-onIconChanged context handler event = do- let logger = hudLogger context- case event of- PropertyEvent { ev_window = wid } -> do- logger $ printf "-Icon- -Event- %s" $ show wid- handler $ Set.singleton wid- _ -> return ()--onIconsChanged :: Context -> IO (Set.Set X11Window -> IO ())-onIconsChanged context =- (.) (void . forkIO) <$> rateLimitFn context onIconsChanged' combineRequests- where- combineRequests windows1 windows2 =- Just (Set.union windows1 windows2, const ((), ()))- onIconsChanged' wids = do- hudLogger context $ printf "-Icon- -Execute- %s" $ show wids- flip runReaderT context $- doWidgetUpdate- (\idx c ->- hudLog (printf "-Icon- -each- Updating %s icons." $ show idx) >>- updateWidget c (IconUpdate $ Set.toList wids))--data WorkspaceContentsController = WorkspaceContentsController- { containerWidget :: Gtk.Widget- , contentsControllers :: [WWC]- }--buildContentsController :: [ControllerConstructor] -> ControllerConstructor-buildContentsController constructors ws = do- controllers <- mapM ($ ws) constructors- tempController <- lift $ do- cons <- Gtk.hBoxNew False 0- mapM_ (Gtk.containerAdd cons . getWidget) controllers- outerBox <- buildPadBox cons- widgetSetClass cons "Contents"- return- WorkspaceContentsController- { containerWidget = Gtk.toWidget outerBox- , contentsControllers = controllers- }- WWC <$> updateWidget tempController (WorkspaceUpdate ws)--buildPadBox :: W.WidgetClass widget => widget -> IO Gtk.EventBox-buildPadBox cons = do- innerBox <- Gtk.hBoxNew False 0- outerBox <- Gtk.eventBoxNew- Gtk.containerAdd innerBox cons- Gtk.containerAdd outerBox innerBox- widgetSetClass innerBox "InnerPad"- widgetSetClass outerBox "OuterPad"- return outerBox--defaultBuildContentsController :: ControllerConstructor-defaultBuildContentsController =- buildContentsController [buildLabelController, buildIconController]--instance WorkspaceWidgetController WorkspaceContentsController where- getWidget = containerWidget- updateWidget cc update = do- Context {hudConfig = cfg} <- ask- lift $- maybe (return ()) (updateMinSize $ Gtk.toWidget $ containerWidget cc) $- minWSWidgetSize cfg- case update of- WorkspaceUpdate newWorkspace ->- lift $ setWorkspaceWidgetStatusClass newWorkspace $ containerWidget cc- _ -> return ()- newControllers <- mapM (`updateWidget` update) $ contentsControllers cc- return cc {contentsControllers = newControllers}- updateWidgetX11 cc update = do- newControllers <- mapM (`updateWidgetX11` update) $ contentsControllers cc- return cc {contentsControllers = newControllers}--data LabelController = LabelController { label :: Gtk.Label }--buildLabelController :: ControllerConstructor-buildLabelController ws = do- tempController <- lift $ do- lbl <- Gtk.labelNew (Nothing :: Maybe String)- widgetSetClass lbl "WorkspaceLabel"- return LabelController { label = lbl }- WWC <$> updateWidget tempController (WorkspaceUpdate ws)--instance WorkspaceWidgetController LabelController where- getWidget = Gtk.toWidget . label- updateWidget lc (WorkspaceUpdate newWorkspace) = do- Context { hudConfig = cfg } <- ask- labelText <- labelSetter cfg newWorkspace- lift $ do- Gtk.labelSetMarkup (label lc) labelText- setWorkspaceWidgetStatusClass newWorkspace $ label lc- return lc- updateWidget lc _ = return lc--data IconWidget = IconWidget- { iconContainer :: Gtk.EventBox- , iconImage :: Gtk.Image- , iconWindow :: MV.MVar (Maybe WindowData)- }--data IconController = IconController- { iconsContainer :: Gtk.HBox- , iconImages :: [IconWidget]- , iconWorkspace :: Workspace- }--buildIconController :: ControllerConstructor-buildIconController ws = do- tempController <-- lift $ do- hbox <- Gtk.hBoxNew False 0- return- IconController- {iconsContainer = hbox, iconImages = [], iconWorkspace = ws}- WWC <$> updateWidget tempController (WorkspaceUpdate ws)--instance WorkspaceWidgetController IconController where- getWidget = Gtk.toWidget . iconsContainer- updateWidget ic (WorkspaceUpdate newWorkspace) = do- newImages <- updateImages ic newWorkspace- return ic { iconImages = newImages, iconWorkspace = newWorkspace }- updateWidget ic (IconUpdate updatedIcons) =- updateWindowIconsById ic updatedIcons >> return ic--updateWindowIconsById :: IconController- -> [X11Window]- -> HUDIO ()-updateWindowIconsById ic windowIds =- mapM_ maybeUpdateWindowIcon $ iconImages ic- where- maybeUpdateWindowIcon widget =- do- info <- lift $ MV.readMVar $ iconWindow widget- when (maybe False (flip elem windowIds . windowId) info) $- updateIconWidget ic widget info False--updateMinSize :: Gtk.Widget -> Int -> IO ()-updateMinSize widget minWidth = do- W.widgetSetSizeRequest widget (-1) (-1)- W.Requisition w _ <- W.widgetSizeRequest widget- when (w < minWidth) $ W.widgetSetSizeRequest widget minWidth $ -1--defaultGetIconInfo :: WindowData -> HUDIO IconInfo-defaultGetIconInfo w =- 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)--sortWindowsByPosition :: [WindowData] -> HUDIO [WindowData]-sortWindowsByPosition wins = do- let getGeometryHUD w = getDisplay >>= liftIO . (`safeGetGeometry` w)- getGeometries = mapM- (forkM return ((((sel2 &&& sel3) <$>) .) getGeometryHUD) . windowId)- wins- windowGeometries <- liftX11Def [] getGeometries- let getLeftPos wd =- fromMaybe (999999999, 99999999) $ lookup (windowId wd) windowGeometries- compareWindowData a b =- compare- (windowMinimized a, getLeftPos a)- (windowMinimized b, getLeftPos b)- return $ sortBy compareWindowData wins--updateImages :: IconController -> Workspace -> HUDIO [IconWidget]-updateImages ic ws = do- Context {hudConfig = cfg} <- ask- sortedWindows <- iconSort cfg $ windows ws- let updateIconWidget' getImageAction wdata ton = do- iconWidget <- getImageAction- _ <- updateIconWidget ic iconWidget wdata ton- return iconWidget- existingImages = map return $ iconImages ic- buildAndAddIconWidget = do- iw <- buildIconWidget ws- lift $ Gtk.containerAdd (iconsContainer ic) $ iconContainer iw- return iw- infiniteImages = existingImages ++ repeat buildAndAddIconWidget- windowCount = length $ windows ws- maxNeeded = maybe windowCount (min windowCount) $ maxIcons cfg- newImagesNeeded = length existingImages < max (minIcons cfg) maxNeeded- -- XXX: Only one of the two things being zipped can be an infinite list,- -- which is why this newImagesNeeded contortion is needed.- imgSrcs =- if newImagesNeeded- then infiniteImages- else existingImages- getImgs = maybe imgSrcs (`take` imgSrcs) $ maxIcons cfg- justWindows = map Just sortedWindows- windowDatas =- if newImagesNeeded- then justWindows ++- replicate (minIcons cfg - length justWindows) Nothing- else justWindows ++ repeat Nothing- transparentOnNones = replicate (minIcons cfg) True ++ repeat False- newImgs <-- sequence $ zipWith3 updateIconWidget' getImgs windowDatas transparentOnNones- when newImagesNeeded $ lift $ Gtk.widgetShowAll $ iconsContainer ic- return newImgs--buildIconWidget :: Workspace -> HUDIO IconWidget-buildIconWidget ws = do- ctx <- ask- lift $ do- img <- Gtk.imageNew- ebox <- Gtk.eventBoxNew- windowVar <- MV.newMVar Nothing- widgetSetClass img "IconImage"- widgetSetClass ebox "IconContainer"- Gtk.containerAdd ebox img- _ <-- Gtk.on ebox Gtk.buttonPressEvent $- liftIO $ do- info <- MV.readMVar windowVar- case info of- Just updatedInfo ->- flip runReaderT ctx $ liftX11Def () $ focusWindow $ windowId updatedInfo- _ -> liftIO $ void $ switch ctx (workspaceIdx ws)- return True- return- IconWidget {iconContainer = ebox, iconImage = img, iconWindow = windowVar}--getWindowStatusString :: WindowData -> String-getWindowStatusString WindowData { windowMinimized = True } = "Minimized"-getWindowStatusString WindowData { windowActive = True } = show Active-getWindowStatusString WindowData { windowUrgent = True } = show Urgent-getWindowStatusString _ = "Normal"--possibleStatusStrings :: [String]-possibleStatusStrings = [show Active, show Urgent, "Minimized", "Normal", "Nodata"]--updateIconWidget- :: IconController- -> IconWidget- -> Maybe WindowData- -> Bool- -> HUDIO ()-updateIconWidget _ IconWidget- { iconContainer = iconButton- , iconImage = image- , iconWindow = windowRef- } windowData transparentOnNone = do- cfg <- asks hudConfig-- let setIconWidgetProperties = do- info <- maybe (return IINone) (getIconInfo cfg) windowData- let imgSize = windowIconSize cfg- statusString = maybe "nodata" getWindowStatusString windowData- iconInfo =- case info of- IINone ->- if transparentOnNone- then transparentInfo- else IINone- _ -> info- lift $ do- mpixBuf <- getPixBuf imgSize iconInfo- setImage imgSize image mpixBuf- updateWidgetClasses iconButton [statusString] possibleStatusStrings-- void $ updateVar windowRef $ const $ setIconWidgetProperties >> return windowData--setImage :: Int -> Gtk.Image -> Maybe Gtk.Pixbuf -> IO ()-setImage imgSize img pixBuf =- case pixBuf of- Just pixbuf -> do- scaledPixbuf <- scalePixbuf imgSize pixbuf- Gtk.imageSetFromPixbuf img scaledPixbuf- Nothing -> Gtk.imageClear img--getPixBuf :: Int -> IconInfo -> IO (Maybe Gtk.Pixbuf)-getPixBuf imgSize = gpb- where- gpb (IIEWMH iconData) = Just <$>- withEWMHIcons iconData (pixBufFromEWMHIcon . selectEWMHIcon imgSize)- gpb (IIFilePath file) = Just <$> pixBufFromFile imgSize file- gpb (IIColor color) = Just <$> pixBufFromColor imgSize color- gpb _ = return Nothing--data WorkspaceButtonController = WorkspaceButtonController- { button :: Gtk.EventBox- , buttonWorkspace :: Workspace- , contentsController :: WWC- }--buildButtonController :: ParentControllerConstructor-buildButtonController contentsBuilder workspace = do- cc <- contentsBuilder workspace- workspacesRef <- asks workspacesVar- ctx <- ask- lift $ do- ebox <- Gtk.eventBoxNew- Gtk.containerAdd ebox $ getWidget cc- Gtk.eventBoxSetVisibleWindow ebox False- _ <-- Gtk.on ebox Gtk.scrollEvent $ do- workspaces <- liftIO $ MV.readMVar workspacesRef- let switchOne a =- liftIO $- flip runReaderT ctx $- liftX11Def- ()- (switchOneWorkspace a (length (M.toList workspaces) - 1)) >>- return True- dir <- Gtk.eventScrollDirection- case dir of- Gtk.ScrollUp -> switchOne True- Gtk.ScrollLeft -> switchOne True- Gtk.ScrollDown -> switchOne False- Gtk.ScrollRight -> switchOne False- Gtk.ScrollSmooth -> return False- _ <- Gtk.on ebox Gtk.buttonPressEvent $ switch ctx $ workspaceIdx workspace- return $- WWC- WorkspaceButtonController- {button = ebox, buttonWorkspace = workspace, contentsController = cc}--switch :: (MonadIO m) => Context -> WorkspaceIdx -> m Bool-switch ctx idx = do- liftIO $ flip runReaderT ctx $ liftX11Def () $ switchToWorkspace idx- return True--instance WorkspaceWidgetController WorkspaceButtonController- where- getWidget wbc = Gtk.toWidget $ button wbc- updateWidget wbc update = do- newContents <- updateWidget (contentsController wbc) update- return wbc { contentsController = newContents }--data WorkspaceUnderlineController = WorkspaceUnderlineController- { table :: T.Table- -- XXX: An event box is used here because we need to change the background- , underline :: Gtk.EventBox- , overlineController :: WWC- }--buildUnderlineController :: ParentControllerConstructor-buildUnderlineController contentsBuilder workspace = do- cfg <- asks hudConfig- cc <- contentsBuilder workspace-- lift $ do- t <- T.tableNew 2 1 False- u <- Gtk.eventBoxNew- W.widgetSetSizeRequest u (-1) $ underlineHeight cfg-- T.tableAttach t (getWidget cc) 0 1 0 1- [T.Expand, T.Fill] [T.Expand, T.Fill] 0 0- T.tableAttach t u 0 1 1 2- [T.Fill] [T.Shrink] (underlinePadding cfg) 0-- widgetSetClass u "Underline"- return $ WWC WorkspaceUnderlineController- {table = t, underline = u, overlineController = cc}--instance WorkspaceWidgetController WorkspaceUnderlineController where- getWidget uc = Gtk.toWidget $ table uc- updateWidget uc wu@(WorkspaceUpdate workspace) =- lift (setWorkspaceWidgetStatusClass workspace (underline uc)) >>- updateUnderline uc wu- updateWidget a b = updateUnderline a b--updateUnderline :: WorkspaceUnderlineController- -> WidgetUpdate- -> HUDIO WorkspaceUnderlineController-updateUnderline uc u = do- newContents <- updateWidget (overlineController uc) u- return uc { overlineController = newContents }--data WorkspaceBorderController =- WorkspaceBorderController { border :: Gtk.EventBox- , borderContents :: Gtk.EventBox- , insideController :: WWC- }--buildBorderController :: ParentControllerConstructor-buildBorderController contentsBuilder workspace = do- cc <- contentsBuilder workspace- cfg <- asks hudConfig- lift $ do- brd <- Gtk.eventBoxNew- cnt <- Gtk.eventBoxNew- Gtk.eventBoxSetVisibleWindow brd True- Gtk.containerSetBorderWidth cnt $ borderWidth cfg- Gtk.containerAdd brd cnt- Gtk.containerAdd cnt $ getWidget cc- widgetSetClass brd "Border"- widgetSetClass cnt "Container"- return $- WWC- WorkspaceBorderController- {border = brd, borderContents = cnt, insideController = cc}--instance WorkspaceWidgetController WorkspaceBorderController where- getWidget bc = Gtk.toWidget $ border bc- updateWidget bc wu@(WorkspaceUpdate workspace) =- let setClasses = setWorkspaceWidgetStatusClass workspace- in lift (setClasses (border bc) >> setClasses (borderContents bc)) >>- updateBorder bc wu- updateWidget a b = updateBorder a b--updateBorder :: WorkspaceBorderController- -> WidgetUpdate- -> HUDIO WorkspaceBorderController-updateBorder bc update = do- newContents <- updateWidget (insideController bc) update- return bc { insideController = newContents }--buildUnderlineButtonController :: ControllerConstructor-buildUnderlineButtonController =- buildButtonController (buildUnderlineController defaultBuildContentsController)--buildBorderButtonController :: ControllerConstructor-buildBorderButtonController =- buildButtonController (buildBorderController defaultBuildContentsController)
− src/gdk_property_change_wrapper.c
@@ -1,29 +0,0 @@-////////////////////////////////////////////////////////////////////////////-// Copyright : (c) Jan Vornberger 2009-// License : BSD3-style (see LICENSE)-//-// Maintainer : jan.vornberger@informatik.uni-oldenburg.de-////////////////////////////////////////////////////////////////////////////---#include <gtk/gtk.h>-#include <gdk/gdk.h>-#include <gdk/gdkkeysyms-compat.h>--void set_strut_properties(GtkWindow *window,- long left, long right, long top, long bottom,- long left_start_y, long left_end_y,- long right_start_y, long right_end_y,- long top_start_x, long top_end_x,- long bottom_start_x, long bottom_end_x) {- gulong data[12] = {0};- data[0] = left; data[1] = right; data[2] = top; data[3] = bottom;- data[4] = left_start_y; data[5] = left_end_y;- data[6] = right_start_y; data[7] = right_end_y;- data[8] = top_start_x; data[9] = top_end_x;- data[10] = bottom_start_x; data[11] = bottom_end_x;-- gdk_property_change(gtk_widget_get_window(GTK_WIDGET(window)),- gdk_atom_intern("_NET_WM_STRUT_PARTIAL", FALSE),- gdk_atom_intern ("CARDINAL", FALSE),- 32, GDK_PROP_MODE_REPLACE, (unsigned char *)data, 12);-}
taffybar.cabal view
@@ -1,5 +1,5 @@ name: taffybar-version: 1.0.2+version: 2.0.0 synopsis: A desktop bar similar to xmobar, but with more GUI license: BSD3 license-file: LICENSE@@ -9,12 +9,17 @@ build-type: Simple cabal-version: >=1.10 tested-with: GHC == 7.10.3, GHC == 8.0.2, GHC == 8.2.2-homepage: http://github.com/travitch/taffybar-data-files: taffybar.css-extra-source-files: README.md,- CHANGELOG.md,- taffybar.hs.example+homepage: http://github.com/taffybar/taffybar+data-files:+ taffybar.css+ icons/*.svg+extra-source-files:+ README.md+ CHANGELOG.md+ taffybar.hs.example+ dbus-xml/org.mpris.MediaPlayer2.Player.xml + description: 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@@ -36,31 +41,39 @@ , cairo , containers , dbus >= 1.0.0 && < 2.0.0+ , dbus-hslogger >= 0.1.0.1 && < 0.2.0.0 , directory , dyre >= 0.8.6 && < 0.9 , either >= 4.0.0.0 , enclosed-exceptions >= 1.0.0.1 , filepath- , haskell-gi-base+ , gi-cairo , gi-gdk- , gi-gdkpixbuf >= 2.0.15+ , gi-gdkpixbuf >= 2.0.16 , gi-gdkx11+ , gi-glib , gi-gtk , glib+ , gtk-sni-tray >= 0.1.2.0+ , gtk-strut >= 0.1.2.0 , gtk-traymanager >= 1.0.1 && < 2.0.0- , gtk3+ , gtk3 >= 0.14.9+ , haskell-gi >= 0.21.2+ , haskell-gi-base >= 0.21.1+ , hslogger , mtl >= 2 , multimap >= 1.2.1 , old-locale , parsec >= 3.1 , process >= 1.0.1.1- , process , rate-limit >= 1.1.1+ , regex-compat , safe >= 0.3 && < 1 , split >= 0.1.4.2+ , status-notifier-item >= 0.2.1.0 , stm , text- , time >= 1.4 && < 1.9+ , time >= 1.4 && < 2.0 , time-locale-compat >= 0.1 && < 0.2 , time-units >= 1.0.0 , transformers >= 0.3.0.0@@ -80,76 +93,87 @@ build-depends: network-uri < 2.6, network < 2.6 hs-source-dirs: src pkgconfig-depends: gtk+-3.0- exposed-modules: System.Information.Battery,- System.Information.CPU,- System.Information.CPU2,- System.Information.DiskIO,- System.Information.EWMHDesktopInfo,- System.Information.Memory,- System.Information.Network,- System.Information.SafeX11- System.Information.StreamInfo,- System.Information.Volume,- System.Information.X11DesktopInfo,- System.Taffybar,- System.Taffybar.Battery,- System.Taffybar.Context,- System.Taffybar.CPUMonitor,- System.Taffybar.CommandRunner,- System.Taffybar.DiskIOMonitor,- System.Taffybar.FSMonitor,- System.Taffybar.FreedesktopNotifications,- System.Taffybar.Hooks.PagerHints,- System.Taffybar.IconImages,- System.Taffybar.LayoutSwitcher,- System.Taffybar.MPRIS,- System.Taffybar.MPRIS2,- System.Taffybar.Menu.DesktopEntry,- System.Taffybar.Menu.Menu,- System.Taffybar.Menu.MenuWidget,- System.Taffybar.Menu.XdgMenu,- System.Taffybar.NetMonitor,- System.Taffybar.Pager,- System.Taffybar.SimpleClock,- System.Taffybar.Systray,- System.Taffybar.TaffyPager,- System.Taffybar.Text.CPUMonitor,- System.Taffybar.Text.MemoryMonitor,- System.Taffybar.ToggleMonitor,- System.Taffybar.Volume,- System.Taffybar.Weather,- System.Taffybar.Widgets.Graph,- System.Taffybar.Widgets.Icon,- System.Taffybar.Widgets.PollingBar,- System.Taffybar.Widgets.PollingGraph,- System.Taffybar.Widgets.PollingLabel,- System.Taffybar.Widgets.Util,- System.Taffybar.Widgets.VerticalBar,- System.Taffybar.WindowSwitcher,- System.Taffybar.WorkspaceHUD-+ exposed-modules: System.Taffybar+ , System.Taffybar.Auth+ , System.Taffybar.Compat.GtkLibs+ , System.Taffybar.Context+ , System.Taffybar.DBus+ , System.Taffybar.DBus.Toggle+ , System.Taffybar.Hooks+ , System.Taffybar.IconImages+ , System.Taffybar.Information.Battery+ , System.Taffybar.Information.CPU+ , System.Taffybar.Information.CPU2+ , System.Taffybar.Information.DiskIO+ , System.Taffybar.Information.EWMHDesktopInfo+ , System.Taffybar.Information.MPRIS2+ , System.Taffybar.Information.Memory+ , System.Taffybar.Information.Network+ , System.Taffybar.Information.SafeX11+ , System.Taffybar.Information.StreamInfo+ , System.Taffybar.Information.Volume+ , System.Taffybar.Information.X11DesktopInfo+ , System.Taffybar.Information.XDG.DesktopEntry+ , System.Taffybar.Information.XDG.Protocol+ , System.Taffybar.SimpleConfig+ , System.Taffybar.Support.PagerHints+ , System.Taffybar.TransparentWindow+ , System.Taffybar.Widget+ , System.Taffybar.Widget.Battery+ , System.Taffybar.Widget.CPUMonitor+ , System.Taffybar.Widget.CommandRunner+ , System.Taffybar.Widget.Decorators+ , System.Taffybar.Widget.DiskIOMonitor+ , System.Taffybar.Widget.FSMonitor+ , System.Taffybar.Widget.FreedesktopNotifications+ , System.Taffybar.Widget.Generic.ChannelGraph+ , System.Taffybar.Widget.Generic.DynamicMenu+ , System.Taffybar.Widget.Generic.Graph+ , System.Taffybar.Widget.Generic.Icon+ , System.Taffybar.Widget.Generic.PollingBar+ , System.Taffybar.Widget.Generic.PollingGraph+ , System.Taffybar.Widget.Generic.PollingLabel+ , System.Taffybar.Widget.Generic.VerticalBar+ , System.Taffybar.Widget.Layout+ , System.Taffybar.Widget.MPRIS2+ , System.Taffybar.Widget.NetMonitor+ , System.Taffybar.Widget.NetworkGraph+ , System.Taffybar.Widget.SNITray+ , System.Taffybar.Widget.SimpleClock+ , System.Taffybar.Widget.Systray+ , System.Taffybar.Widget.Text.CPUMonitor+ , System.Taffybar.Widget.Text.MemoryMonitor+ , System.Taffybar.Widget.Text.NetworkMonitor+ , System.Taffybar.Widget.Util+ , System.Taffybar.Widget.Volume+ , System.Taffybar.Widget.Weather+ , System.Taffybar.Widget.Windows+ , System.Taffybar.Widget.Workspaces+ , System.Taffybar.Widget.XDGMenu.Menu+ , System.Taffybar.Widget.XDGMenu.MenuWidget+ other-modules: Paths_taffybar- , System.Taffybar.GtkLibCompat- , System.Taffybar.PixbufCompat- , System.Taffybar.StrutProperties+ , System.Taffybar.Information.DBusClients+ , System.Taffybar.Information.DBusObjects , System.Taffybar.Util - c-sources: src/gdk_property_change_wrapper.c cc-options: -fPIC- ghc-options: -Wall -funbox-strict-fields+ ghc-options: -Wall -funbox-strict-fields -fno-warn-orphans executable taffybar default-language: Haskell2010 build-depends: base > 3 && < 5+ , hslogger+ , optparse-applicative , taffybar + other-modules: Paths_taffybar+ hs-source-dirs: app main-is: Main.hs pkgconfig-depends: gtk+-3.0- c-sources: src/gdk_property_change_wrapper.c ghc-options: -Wall -rtsopts -threaded source-repository head type: git- location: git://github.com/travitch/taffybar.git-+ location: git://github.com/taffybar/taffybar.git
taffybar.css view
@@ -23,6 +23,10 @@ font-size: 12pt; } +.Menu {+ background-color: @bg-color;+}+ .IconContainer { transition: background-color .5s; border-radius: 5px;@@ -49,7 +53,7 @@ opacity: 1; } -#WindowSwitcher {+#Windows { background-color: @bg-color; }
taffybar.hs.example view
@@ -1,17 +1,11 @@ module Main where -import System.Information.CPU-import System.Information.Memory-import System.Taffybar-import System.Taffybar.FreedesktopNotifications-import System.Taffybar.MPRIS-import System.Taffybar.SimpleClock-import System.Taffybar.Systray-import System.Taffybar.TaffyPager-import System.Taffybar.Weather-import System.Taffybar.Widgets.PollingBar-import System.Taffybar.Widgets.PollingGraph-import System.Taffybar.WorkspaceHUD+import System.Taffybar+import System.Taffybar.Information.CPU+import System.Taffybar.Information.Memory+import System.Taffybar.SimpleConfig+import System.Taffybar.Widget+import System.Taffybar.Widget.Generic.PollingGraph memCallback = do mi <- parseMeminfo@@ -22,22 +16,28 @@ return [totalLoad, systemLoad] main = do- let memCfg = defaultGraphConfig { graphDataColors = [(1, 0, 0, 1)]- , graphLabel = Just "mem"- }- cpuCfg = defaultGraphConfig { graphDataColors = [ (0, 1, 0, 1)- , (1, 0, 1, 0.5)- ]- , graphLabel = Just "cpu"- }+ let memCfg = defaultGraphConfig+ { graphDataColors = [(1, 0, 0, 1)]+ , graphLabel = Just "mem"+ }+ cpuCfg = defaultGraphConfig+ { graphDataColors =+ [ (0, 1, 0, 1)+ , (1, 0, 1, 0.5)+ ]+ , graphLabel = Just "cpu"+ } let clock = textClockNew Nothing "<span fgcolor='orange'>%a %b %_d %H:%M</span>" 1- pager = taffyPagerHUDNew defaultPagerConfig defaultWorkspaceHUDConfig+ workspaces = workspacesNew defaultWorkspacesConfig+ windows = windowsNew defaultWindowsConfig+ layout = layoutNew defaultLayoutconfig note = notifyAreaNew defaultNotificationConfig wea = weatherNew (defaultWeatherConfig "KMSN") 10- mpris = mprisNew defaultMPRISConfig+ mpris = mpris2New mem = pollingGraphNew memCfg 1 memCallback cpu = pollingGraphNew cpuCfg 0.5 cpuCallback tray = systrayNew- defaultTaffybar defaultTaffybarConfig { startWidgets = [ pager, note ]- , endWidgets = [ tray, wea, clock, mem, cpu, mpris ]- }+ simpleTaffybar defaultSimpleTaffyConfig+ { startWidgets = [ workspaces, layout, windows, note ]+ , endWidgets = [ tray, wea, clock, mem, cpu, mpris ]+ }