diff --git a/CHANGELOG.md b/CHANGELOG.md
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -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
diff --git a/README.md b/README.md
--- a/README.md
+++ b/README.md
@@ -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)
diff --git a/app/Main.hs b/app/Main.hs
--- a/app/Main.hs
+++ b/app/Main.hs
@@ -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
diff --git a/dbus-xml/org.mpris.MediaPlayer2.Player.xml b/dbus-xml/org.mpris.MediaPlayer2.Player.xml
new file mode 100644
--- /dev/null
+++ b/dbus-xml/org.mpris.MediaPlayer2.Player.xml
@@ -0,0 +1,30 @@
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/icons/play.svg b/icons/play.svg
new file mode 100644
--- /dev/null
+++ b/icons/play.svg
@@ -0,0 +1,42 @@
+
+
+
diff --git a/src/System/Information/Battery.hs b/src/System/Information/Battery.hs
deleted file mode 100644
--- a/src/System/Information/Battery.hs
+++ /dev/null
@@ -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
diff --git a/src/System/Information/CPU.hs b/src/System/Information/CPU.hs
deleted file mode 100644
--- a/src/System/Information/CPU.hs
+++ /dev/null
@@ -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)
diff --git a/src/System/Information/CPU2.hs b/src/System/Information/CPU2.hs
deleted file mode 100644
--- a/src/System/Information/CPU2.hs
+++ /dev/null
@@ -1,57 +0,0 @@
------------------------------------------------------------------------------
--- |
--- Module : System.Information.CPU2
--- Copyright : (c) José A. Romero L.
--- License : BSD3-style (see LICENSE)
---
--- Maintainer : José A. Romero L.
--- 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))
-
diff --git a/src/System/Information/DiskIO.hs b/src/System/Information/DiskIO.hs
deleted file mode 100644
--- a/src/System/Information/DiskIO.hs
+++ /dev/null
@@ -1,42 +0,0 @@
------------------------------------------------------------------------------
--- |
--- Module : System.Information.DiskIO
--- Copyright : (c) José A. Romero L.
--- License : BSD3-style (see LICENSE)
---
--- Maintainer : José A. Romero L.
--- 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])
-
diff --git a/src/System/Information/EWMHDesktopInfo.hs b/src/System/Information/EWMHDesktopInfo.hs
deleted file mode 100644
--- a/src/System/Information/EWMHDesktopInfo.hs
+++ /dev/null
@@ -1,224 +0,0 @@
------------------------------------------------------------------------------
--- |
--- Module : System.Information.EWMHDesktopInfo
--- Copyright : (c) José A. Romero L.
--- License : BSD3-style (see LICENSE)
---
--- Maintainer : José A. Romero L.
--- 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)
diff --git a/src/System/Information/Memory.hs b/src/System/Information/Memory.hs
deleted file mode 100644
--- a/src/System/Information/Memory.hs
+++ /dev/null
@@ -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
- }
diff --git a/src/System/Information/Network.hs b/src/System/Information/Network.hs
deleted file mode 100644
--- a/src/System/Information/Network.hs
+++ /dev/null
@@ -1,61 +0,0 @@
------------------------------------------------------------------------------
--- |
--- Module : System.Information.Network
--- Copyright : (c) José A. Romero L.
--- License : BSD3-style (see LICENSE)
---
--- Maintainer : José A. Romero L.
--- 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
diff --git a/src/System/Information/SafeX11.hsc b/src/System/Information/SafeX11.hsc
deleted file mode 100644
--- a/src/System/Information/SafeX11.hsc
+++ /dev/null
@@ -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
diff --git a/src/System/Information/StreamInfo.hs b/src/System/Information/StreamInfo.hs
deleted file mode 100644
--- a/src/System/Information/StreamInfo.hs
+++ /dev/null
@@ -1,90 +0,0 @@
---------------------------------------------------------------------------------
--- |
--- Module : System.Information.StreamInfo
--- Copyright : (c) José A. Romero L.
--- License : BSD3-style (see LICENSE)
---
--- Maintainer : José A. Romero L.
--- 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
-
diff --git a/src/System/Information/Volume.hs b/src/System/Information/Volume.hs
deleted file mode 100644
--- a/src/System/Information/Volume.hs
+++ /dev/null
@@ -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
diff --git a/src/System/Information/X11DesktopInfo.hs b/src/System/Information/X11DesktopInfo.hs
deleted file mode 100644
--- a/src/System/Information/X11DesktopInfo.hs
+++ /dev/null
@@ -1,282 +0,0 @@
------------------------------------------------------------------------------
--- |
--- Module : System.Information.X11DesktopInfo
--- Copyright : (c) José A. Romero L.
--- License : BSD3-style (see LICENSE)
---
--- Maintainer : José A. Romero L.
--- 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
diff --git a/src/System/Taffybar.hs b/src/System/Taffybar.hs
--- a/src/System/Taffybar.hs
+++ b/src/System/Taffybar.hs
@@ -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 "%a %b %_d %H:%M" 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-\\/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 .
-
- -- * 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
+ -- .
+ 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 ()
diff --git a/src/System/Taffybar/Auth.hs b/src/System/Taffybar/Auth.hs
new file mode 100644
--- /dev/null
+++ b/src/System/Taffybar/Auth.hs
@@ -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)
diff --git a/src/System/Taffybar/Battery.hs b/src/System/Taffybar/Battery.hs
deleted file mode 100644
--- a/src/System/Taffybar/Battery.hs
+++ /dev/null
@@ -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)
diff --git a/src/System/Taffybar/CPUMonitor.hs b/src/System/Taffybar/CPUMonitor.hs
deleted file mode 100644
--- a/src/System/Taffybar/CPUMonitor.hs
+++ /dev/null
@@ -1,40 +0,0 @@
---------------------------------------------------------------------------------
--- |
--- Module : System.Taffybar.CPUMonitor
--- Copyright : (c) José A. Romero L.
--- License : BSD3-style (see LICENSE)
---
--- Maintainer : José A. Romero L.
--- 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 []
diff --git a/src/System/Taffybar/CommandRunner.hs b/src/System/Taffybar/CommandRunner.hs
deleted file mode 100644
--- a/src/System/Taffybar/CommandRunner.hs
+++ /dev/null
@@ -1,48 +0,0 @@
---------------------------------------------------------------------------------
--- |
--- Module : System.Taffybar.CommandRunner
--- Copyright : (c) Arseniy Seroka
--- License : BSD3-style (see LICENSE)
---
--- Maintainer : Arseniy Seroka
--- 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
diff --git a/src/System/Taffybar/Compat/GtkLibs.hs b/src/System/Taffybar/Compat/GtkLibs.hs
new file mode 100644
--- /dev/null
+++ b/src/System/Taffybar/Compat/GtkLibs.hs
@@ -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
diff --git a/src/System/Taffybar/Context.hs b/src/System/Taffybar/Context.hs
--- a/src/System/Taffybar/Context.hs
+++ b/src/System/Taffybar/Context.hs
@@ -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
diff --git a/src/System/Taffybar/DBus.hs b/src/System/Taffybar/DBus.hs
new file mode 100644
--- /dev/null
+++ b/src/System/Taffybar/DBus.hs
@@ -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
diff --git a/src/System/Taffybar/DBus/Toggle.hs b/src/System/Taffybar/DBus/Toggle.hs
new file mode 100644
--- /dev/null
+++ b/src/System/Taffybar/DBus/Toggle.hs
@@ -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
+ }
diff --git a/src/System/Taffybar/DiskIOMonitor.hs b/src/System/Taffybar/DiskIOMonitor.hs
deleted file mode 100644
--- a/src/System/Taffybar/DiskIOMonitor.hs
+++ /dev/null
@@ -1,37 +0,0 @@
---------------------------------------------------------------------------------
--- |
--- Module : System.Taffybar.DiskIOMonitor
--- Copyright : (c) José A. Romero L.
--- License : BSD3-style (see LICENSE)
---
--- Maintainer : José A. Romero L.
--- 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
diff --git a/src/System/Taffybar/FSMonitor.hs b/src/System/Taffybar/FSMonitor.hs
deleted file mode 100644
--- a/src/System/Taffybar/FSMonitor.hs
+++ /dev/null
@@ -1,38 +0,0 @@
------------------------------------------------------------------------------
--- |
--- Module : System.Taffybar.FSMonitor
--- Copyright : (c) José A. Romero L.
--- License : BSD3-style (see LICENSE)
---
--- Maintainer : José A. Romero L.
--- 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
diff --git a/src/System/Taffybar/FreedesktopNotifications.hs b/src/System/Taffybar/FreedesktopNotifications.hs
deleted file mode 100644
--- a/src/System/Taffybar/FreedesktopNotifications.hs
+++ /dev/null
@@ -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 "" <> prefix <> "" <> 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
diff --git a/src/System/Taffybar/GtkLibCompat.hs b/src/System/Taffybar/GtkLibCompat.hs
deleted file mode 100644
--- a/src/System/Taffybar/GtkLibCompat.hs
+++ /dev/null
@@ -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
diff --git a/src/System/Taffybar/Hooks.hs b/src/System/Taffybar/Hooks.hs
new file mode 100644
--- /dev/null
+++ b/src/System/Taffybar/Hooks.hs
@@ -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
diff --git a/src/System/Taffybar/Hooks/PagerHints.hs b/src/System/Taffybar/Hooks/PagerHints.hs
deleted file mode 100644
--- a/src/System/Taffybar/Hooks/PagerHints.hs
+++ /dev/null
@@ -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.
--- 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
diff --git a/src/System/Taffybar/IconImages.hs b/src/System/Taffybar/IconImages.hs
--- a/src/System/Taffybar/IconImages.hs
+++ b/src/System/Taffybar/IconImages.hs
@@ -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
diff --git a/src/System/Taffybar/Information/Battery.hs b/src/System/Taffybar/Information/Battery.hs
new file mode 100644
--- /dev/null
+++ b/src/System/Taffybar/Information/Battery.hs
@@ -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
diff --git a/src/System/Taffybar/Information/CPU.hs b/src/System/Taffybar/Information/CPU.hs
new file mode 100644
--- /dev/null
+++ b/src/System/Taffybar/Information/CPU.hs
@@ -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)
diff --git a/src/System/Taffybar/Information/CPU2.hs b/src/System/Taffybar/Information/CPU2.hs
new file mode 100644
--- /dev/null
+++ b/src/System/Taffybar/Information/CPU2.hs
@@ -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.
+-- 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))
+
diff --git a/src/System/Taffybar/Information/DBusClients.hs b/src/System/Taffybar/Information/DBusClients.hs
new file mode 100644
--- /dev/null
+++ b/src/System/Taffybar/Information/DBusClients.hs
@@ -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
diff --git a/src/System/Taffybar/Information/DBusObjects.hs b/src/System/Taffybar/Information/DBusObjects.hs
new file mode 100644
--- /dev/null
+++ b/src/System/Taffybar/Information/DBusObjects.hs
@@ -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"
+ }
diff --git a/src/System/Taffybar/Information/DiskIO.hs b/src/System/Taffybar/Information/DiskIO.hs
new file mode 100644
--- /dev/null
+++ b/src/System/Taffybar/Information/DiskIO.hs
@@ -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.
+-- 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])
+
diff --git a/src/System/Taffybar/Information/EWMHDesktopInfo.hs b/src/System/Taffybar/Information/EWMHDesktopInfo.hs
new file mode 100644
--- /dev/null
+++ b/src/System/Taffybar/Information/EWMHDesktopInfo.hs
@@ -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.
+-- 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)
diff --git a/src/System/Taffybar/Information/MPRIS2.hs b/src/System/Taffybar/Information/MPRIS2.hs
new file mode 100644
--- /dev/null
+++ b/src/System/Taffybar/Information/MPRIS2.hs
@@ -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)
diff --git a/src/System/Taffybar/Information/Memory.hs b/src/System/Taffybar/Information/Memory.hs
new file mode 100644
--- /dev/null
+++ b/src/System/Taffybar/Information/Memory.hs
@@ -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
+ }
diff --git a/src/System/Taffybar/Information/Network.hs b/src/System/Taffybar/Information/Network.hs
new file mode 100644
--- /dev/null
+++ b/src/System/Taffybar/Information/Network.hs
@@ -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.
+-- 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)
diff --git a/src/System/Taffybar/Information/SafeX11.hsc b/src/System/Taffybar/Information/SafeX11.hsc
new file mode 100644
--- /dev/null
+++ b/src/System/Taffybar/Information/SafeX11.hsc
@@ -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
diff --git a/src/System/Taffybar/Information/StreamInfo.hs b/src/System/Taffybar/Information/StreamInfo.hs
new file mode 100644
--- /dev/null
+++ b/src/System/Taffybar/Information/StreamInfo.hs
@@ -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.
+-- 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
diff --git a/src/System/Taffybar/Information/Volume.hs b/src/System/Taffybar/Information/Volume.hs
new file mode 100644
--- /dev/null
+++ b/src/System/Taffybar/Information/Volume.hs
@@ -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
diff --git a/src/System/Taffybar/Information/X11DesktopInfo.hs b/src/System/Taffybar/Information/X11DesktopInfo.hs
new file mode 100644
--- /dev/null
+++ b/src/System/Taffybar/Information/X11DesktopInfo.hs
@@ -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.
+-- 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
diff --git a/src/System/Taffybar/Information/XDG/DesktopEntry.hs b/src/System/Taffybar/Information/XDG/DesktopEntry.hs
new file mode 100644
--- /dev/null
+++ b/src/System/Taffybar/Information/XDG/DesktopEntry.hs
@@ -0,0 +1,215 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : System.Taffybar.Information.XDG.DesktopEntry
+-- Copyright : 2017 Ulf Jasper
+-- License : BSD3-style (see LICENSE)
+--
+-- Maintainer : Ulf Jasper
+-- Stability : unstable
+-- Portability : unportable
+--
+-- Implementation of version 1.1 of the freedesktop "Desktop Entry
+-- specification", see
+-- https://specifications.freedesktop.org/desktop-entry-spec/desktop-entry-spec-1.1.html.
+-----------------------------------------------------------------------------
+
+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. % 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
+ }
diff --git a/src/System/Taffybar/Information/XDG/Protocol.hs b/src/System/Taffybar/Information/XDG/Protocol.hs
new file mode 100644
--- /dev/null
+++ b/src/System/Taffybar/Information/XDG/Protocol.hs
@@ -0,0 +1,259 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : System.Taffybar.Information.XDG.Protocol
+-- Copyright : 2017 Ulf Jasper
+-- License : BSD3-style (see LICENSE)
+--
+-- Maintainer : Ulf Jasper
+-- Stability : unstable
+-- Portability : unportable
+--
+-- Implementation of version 1.1 of the XDG "Desktop Menu
+-- Specification", see
+-- https://specifications.freedesktop.org/menu-spec/menu-spec-1.1.html
+---- specification, see
+-- See also 'MenuWidget'.
+--
+-----------------------------------------------------------------------------
+module System.Taffybar.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)
diff --git a/src/System/Taffybar/LayoutSwitcher.hs b/src/System/Taffybar/LayoutSwitcher.hs
deleted file mode 100644
--- a/src/System/Taffybar/LayoutSwitcher.hs
+++ /dev/null
@@ -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.
--- 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)
diff --git a/src/System/Taffybar/MPRIS.hs b/src/System/Taffybar/MPRIS.hs
deleted file mode 100644
--- a/src/System/Taffybar/MPRIS.hs
+++ /dev/null
@@ -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 = "▶ " ++
- 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)
diff --git a/src/System/Taffybar/MPRIS2.hs b/src/System/Taffybar/MPRIS2.hs
deleted file mode 100644
--- a/src/System/Taffybar/MPRIS2.hs
+++ /dev/null
@@ -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 = "▶ " ++ 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 ()
diff --git a/src/System/Taffybar/Menu/DesktopEntry.hs b/src/System/Taffybar/Menu/DesktopEntry.hs
deleted file mode 100644
--- a/src/System/Taffybar/Menu/DesktopEntry.hs
+++ /dev/null
@@ -1,179 +0,0 @@
-{-# OPTIONS_HADDOCK hide #-}
------------------------------------------------------------------------------
--- |
--- Module : System.Taffybar.Menu.DesktopEntry
--- Copyright : 2017 Ulf Jasper
--- License : BSD3-style (see LICENSE)
---
--- Maintainer : Ulf Jasper
--- Stability : unstable
--- Portability : unportable
---
--- Implementation of version 1.1 of the freedesktop "Desktop Entry
--- specification", see
--- https://specifications.freedesktop.org/desktop-entry-spec/desktop-entry-spec-1.1.html.
---
--- See also 'MenuWidget'.
------------------------------------------------------------------------------
-
-module System.Taffybar.Menu.DesktopEntry (
- DesktopEntry(..),
- listDesktopEntries,
- getDirectoryEntry,
- deHasCategory,
- deName,
- deOnlyShowIn,
- deNotShowIn,
- deComment,
- deCommand,
- deIcon,
- deNoDisplay)
-
-where
-
-import Control.Monad.Except
-import Data.Char
-import qualified Data.ConfigFile as CF
-import Data.List
-import Data.Maybe
-import System.Directory
-import System.FilePath.Posix
-
-data DesktopEntryType = Application | Link | Directory
- deriving (Read, Show, Eq)
-
--- | Desktop Entry. All attributes (key-value-pairs) are stored in an
--- association list.
-data DesktopEntry = DesktopEntry {
- deType :: DesktopEntryType,
- deFilename :: FilePath, -- ^ unqualified filename, e.g. "taffybar.desktop"
- deAttributes :: [(String, String)], -- ^ Key-value pairs
- deAllocated :: Bool -- ^ already contained in some menu?
- }
- deriving (Read, Show, Eq)
-
--- | Determine whether the Category attribute of a desktop entry
--- contains a given value.
-deHasCategory :: DesktopEntry -- ^ desktop entry
- -> String -- ^ category to be checked
- -> Bool
-deHasCategory de cat = case lookup "Categories" (deAttributes de) of
- Nothing -> False
- Just cats -> cat `elem` splitAtSemicolon cats
-
-splitAtSemicolon :: String -> [String]
-splitAtSemicolon = lines . (map (\c -> if c == ';' then '\n' else c))
-
--- | Return the proper name of the desktop entry, depending on the
--- list of preferred languages.
-deName :: [String] -- ^ Preferred languages
- -> DesktopEntry
- -> String
-deName langs de = fromMaybe (deFilename de) $ deLocalisedAtt langs de "Name"
-
--- | Return the categories in which the entry shall be shown
-deOnlyShowIn :: DesktopEntry -> [String]
-deOnlyShowIn = maybe [] (splitAtSemicolon) . deAtt "OnlyShowIn"
-
--- | Return the categories in which the entry shall not be shown
-deNotShowIn :: DesktopEntry -> [String]
-deNotShowIn = maybe [] (splitAtSemicolon) . deAtt "NotShowIn"
-
--- | Return the value of the given attribute key
-deAtt :: String -> DesktopEntry -> Maybe String
-deAtt att = lookup att . deAttributes
-
--- | Return the Icon attribute
-deIcon :: DesktopEntry -> Maybe String
-deIcon = deAtt "Icon"
-
--- | Return True if the entry must not be displayed
-deNoDisplay :: DesktopEntry -> Bool
-deNoDisplay de = maybe False (("true" ==) . (map toLower)) $ deAtt "NoDisplay" de
-
-deLocalisedAtt :: [String] -- ^ Preferred languages
- -> DesktopEntry
- -> String
- -> Maybe String
-deLocalisedAtt langs de att =
- let localeMatches = catMaybes $ map (\l -> lookup (att ++ "[" ++ l ++ "]") (deAttributes de)) langs
- in if null localeMatches
- then lookup att $ deAttributes de
- else Just $ head localeMatches
-
--- | Return the proper comment of the desktop entry, depending on the
--- list of preferred languages.
-deComment :: [String] -- ^ Preferred languages
- -> DesktopEntry
- -> Maybe String
-deComment langs de = deLocalisedAtt langs de "Comment"
-
--- | Return the command defined by the given desktop entry. FIXME:
--- should check the dbus thing. FIXME: are there "field codes",
--- i.e. % things, that should be respected?
-deCommand :: DesktopEntry -> Maybe String
-deCommand de =
- case lookup "Exec" (deAttributes de) of
- Nothing -> Nothing
- Just cmd -> Just $ reverse $ dropWhile (== ' ') $ reverse $ takeWhile (/= '%') cmd
-
--- | Return a list of all desktop entries in the given directory.
-listDesktopEntries :: String -> FilePath -> IO [DesktopEntry]
-listDesktopEntries extension dir = do
- let ndir = normalise dir
- putStrLn $ "Listing desktop entries in " ++ ndir
- ex <- doesDirectoryExist ndir
- if ex
- then do files <- mapM (return . (ndir ))
- =<< return . filter (/= ".")
- =<< return . filter (/= "..")
- =<< getDirectoryContents dir
- mEntries <- mapM (readDesktopEntry) $ filter (extension `isSuffixOf`) files
- let entries = nub $ catMaybes mEntries
- subDirs <- filterM doesDirectoryExist files
- subEntries <- return . concat =<< mapM (listDesktopEntries extension) subDirs
- return $ entries ++ subEntries
- else do putStrLn $ "Does not exist: " ++ ndir
- return []
-
--- | Return a list of all desktop entries in the given directory.
-getDirectoryEntry :: String -> [FilePath] -> IO (Maybe DesktopEntry)
-getDirectoryEntry name dirs = do
- exFiles <- filterM doesFileExist $ map (( name) . normalise) dirs
- if null exFiles
- then return Nothing
- else readDesktopEntry $ head exFiles
-
--- | Main section of a desktop entry file.
-sectionMain :: String
-sectionMain = "Desktop Entry"
-
--- | Read a desktop entry from a file.
-readDesktopEntry :: FilePath -> IO (Maybe DesktopEntry)
-readDesktopEntry fp = do
- ex <- doesFileExist fp
- if ex
- then doReadDesktopEntry fp
- else do putStrLn $ "File does not exist: '" ++ fp ++ "'"
- return Nothing
-
- where doReadDesktopEntry :: FilePath -> IO (Maybe DesktopEntry)
- doReadDesktopEntry f = do
- eResult <- runExceptT $ do
- cp <- join $ liftIO $ CF.readfile CF.emptyCP f
- items <- CF.items cp sectionMain
- return items
-
- case eResult of
- Left _ -> return Nothing
- Right r -> return $ Just $ DesktopEntry
- {deType = maybe Application read (lookup "Type" r),
- deFilename = f,
- deAttributes = r,
- deAllocated = False}
-
--- -- | Test
--- testDesktopEntry :: IO ()
--- testDesktopEntry = do
--- print =<< readDesktopEntry "/usr/share/applications/taffybar.desktop"
-
diff --git a/src/System/Taffybar/Menu/Menu.hs b/src/System/Taffybar/Menu/Menu.hs
deleted file mode 100644
--- a/src/System/Taffybar/Menu/Menu.hs
+++ /dev/null
@@ -1,124 +0,0 @@
-{-# OPTIONS_HADDOCK hide #-}
------------------------------------------------------------------------------
--- |
--- Module : System.Taffybar.Menu.Menu
--- Copyright : 2017 Ulf Jasper
--- License : BSD3-style (see LICENSE)
---
--- Maintainer : Ulf Jasper
--- Stability : unstable
--- Portability : unportable
---
--- Implementation of version 1.1 of the freedesktop "Desktop Menu
--- Specification", see
--- https://specifications.freedesktop.org/menu-spec/menu-spec-1.1.html
---
--- See also 'MenuWidget'.
------------------------------------------------------------------------------
-
-module System.Taffybar.Menu.Menu (
- Menu(..),
- MenuEntry(..),
- buildMenu,
- getApplicationEntries)
-where
-
-import Data.Char (toLower)
-import Data.List
-import Data.Maybe
-import System.Taffybar.Menu.DesktopEntry
-import System.Taffybar.Menu.XdgMenu
-
--- | Displayable menu
-data Menu = Menu {
- fmName :: String,
- fmComment :: String,
- fmIcon :: Maybe String,
- fmSubmenus :: [Menu],
- fmEntries :: [MenuEntry],
- fmOnlyUnallocated :: Bool}
- deriving (Show)
-
--- | Displayable menu entry
-data MenuEntry = MenuEntry {
- feName :: String,
- feComment :: String,
- feCommand :: String,
- feIcon :: Maybe String}
- deriving (Eq, Show)
-
-
--- | Fetch menus and desktop entries and assemble the menu.
-buildMenu :: Maybe String -> IO Menu
-buildMenu mMenuPrefix = do
- mMenuDes <- readXdgMenu mMenuPrefix
- case mMenuDes of
- Nothing -> return $ Menu "???" "Parsing failed" Nothing [] [] False
- Just (menu, des) -> do dt <- getXdgDesktop
- dirDirs <- getDirectoryDirs
- langs <- getPreferredLanguages
- (fm, ae) <- xdgToMenu dt langs dirDirs des menu
- let fm' = fixOnlyUnallocated ae fm
- return fm'
-
--- | Convert xdg menu to displayable menu
-xdgToMenu :: String -> [String] -> [FilePath] -> [DesktopEntry] -> XdgMenu
- -> IO (Menu, [MenuEntry])
-xdgToMenu desktop langs dirDirs des xm = do
- dirEntry <- getDirectoryEntry (xmDirectory xm) dirDirs
- mas <- mapM (xdgToMenu desktop langs dirDirs des) (xmSubmenus xm)
- let (menus, subaes) = unzip mas
- menus' = sortBy (\fm1 fm2 -> compare (map toLower $ fmName fm1)
- (map toLower $ fmName fm2)) menus
- entries = map (xdgToMenuEntry langs) $
- -- hide NoDisplay
- filter (not . deNoDisplay) $
- -- onlyshowin
- filter (matchesOnlyShowIn desktop) $
- -- excludes
- filter (not . flip matchesCondition (fromMaybe None (xmExclude xm))) $
- -- includes
- filter (flip matchesCondition (fromMaybe None (xmInclude xm))) des
- onlyUnallocated = xmOnlyUnallocated xm
- aes = if onlyUnallocated then [] else entries ++ concat subaes
- let fm = Menu {fmName = maybe (xmName xm) (deName langs) dirEntry,
- fmComment = maybe "???" (fromMaybe "???" . deComment langs) dirEntry,
- fmIcon = deIcon =<< dirEntry,
- fmSubmenus = menus',
- fmEntries = entries,
- fmOnlyUnallocated = onlyUnallocated}
- return (fm, aes)
-
--- | Check the "only show in" logic
-matchesOnlyShowIn :: String -> DesktopEntry -> Bool
-matchesOnlyShowIn desktop de = matchesShowIn && notMatchesNotShowIn
- where matchesShowIn = case deOnlyShowIn de of
- [] -> True
- desktops -> desktop `elem` desktops
- notMatchesNotShowIn = case deNotShowIn de of
- [] -> True
- desktops -> not $ desktop `elem` desktops
-
--- | convert xdg desktop entry to displayble menu entry
-xdgToMenuEntry :: [String] -> DesktopEntry -> MenuEntry
-xdgToMenuEntry langs de = MenuEntry {feName = name,
- feComment = comment,
- feCommand = cmd,
- feIcon = mIcon}
- where mc = case deCommand de of
- Nothing -> Nothing
- Just c -> Just $ "(" ++ c ++ ")"
- comment = fromMaybe "??" $ case deComment langs de of
- Nothing -> mc
- Just tt -> Just $ tt ++ maybe "" ("\n" ++) mc
- cmd = fromMaybe "FIXME" $ deCommand de
- name = deName langs de
- mIcon = deIcon de
-
--- | postprocess unallocated entries
-fixOnlyUnallocated :: [MenuEntry] -> Menu -> Menu
-fixOnlyUnallocated fes fm = fm {fmEntries = entries,
- fmSubmenus = map (fixOnlyUnallocated fes) (fmSubmenus fm)}
- where entries = if (fmOnlyUnallocated fm)
- then filter (not . (`elem` fes)) (fmEntries fm)
- else fmEntries fm
diff --git a/src/System/Taffybar/Menu/MenuWidget.hs b/src/System/Taffybar/Menu/MenuWidget.hs
deleted file mode 100644
--- a/src/System/Taffybar/Menu/MenuWidget.hs
+++ /dev/null
@@ -1,129 +0,0 @@
------------------------------------------------------------------------------
--- |
--- Module : System.Taffybar.Menu.MenuWidget
--- Copyright : 2017 Ulf Jasper
--- License : BSD3-style (see LICENSE)
---
--- Maintainer : Ulf Jasper
--- Stability : unstable
--- Portability : unportable
---
--- MenuWidget provides a hierachical GTK menu containing all
--- applicable desktop entries found on the system. The menu is built
--- according to the version 1.1 of the XDG "Desktop Menu
--- Specification", see
--- https://specifications.freedesktop.org/menu-spec/menu-spec-1.1.html
------------------------------------------------------------------------------
-
-module System.Taffybar.Menu.MenuWidget (
- -- * Usage
- -- $usage
- menuWidgetNew)
-where
-
-import Control.Monad
-import Graphics.UI.Gtk hiding (Menu)
-import System.Directory
-import System.FilePath.Posix
-import System.Process
-import System.Taffybar.Menu.Menu
-
--- $usage
---
--- In order to use this widget add the following line to your
--- @taffybar.hs@ file:
---
--- > import System.Taffybar.Menu.MenuWidget
--- > main = do
--- > let menu = menuWidgetNew $ Just "PREFIX-"
---
--- The menu will look for a file named "PREFIX-applications.menu" in
--- the (subdirectory "menus" of the) directories specified by the
--- environment variable XDG_CONFIG_DIRS and "/etc/xdg". If no prefix
--- is given (i.e. if you pass Nothing) then the value of the
--- environment variable XDG_MENU_PREFIX is used, if it is set. If
--- taffybar is running inside a desktop environment like Mate, Gnome,
--- XFCE etc. the environment variables XDG_CONFIG_DIRS and
--- XDG_MENU_PREFIX should be set and you may create the menu like this:
---
--- > let menu = menuWidgetNew Nothing
---
--- Now you can use @menu@ as any other Taffybar widget.
-
-
--- | Add a desktop entry to a gtk menu by appending a gtk menu item.
-addItem :: (MenuShellClass msc) =>
- msc -- ^ GTK menu
- -> MenuEntry -- ^ Desktop entry
- -> IO ()
-addItem ms de = do
- item <- imageMenuItemNewWithLabel (feName de)
- set item [ widgetTooltipText := Just (feComment de)]
- setIcon item (feIcon de)
- menuShellAppend ms item
- _ <- on item menuItemActivated $ do
- let cmd = feCommand de
- putStrLn $ "Launching '" ++ cmd ++ "'"
- _ <- spawnCommand cmd
- return ()
- return ()
-
--- | Add an xdg menu to a gtk menu by appending gtk menu items and
--- submenus.
-addMenu :: (MenuShellClass msc) =>
- msc -- ^ GTK menu
- -> Menu -- ^ menu
- -> IO ()
-addMenu ms fm = do
- let subMenus = fmSubmenus fm
- items = fmEntries fm
- when (not (null items) || not (null subMenus)) $ do
- item <- imageMenuItemNewWithLabel (fmName fm)
- setIcon item (fmIcon fm)
- menuShellAppend ms item
- subMenu <- menuNew
- menuItemSetSubmenu item subMenu
- mapM_ (addMenu subMenu) subMenus
- mapM_ (addItem subMenu) $ items
-
-setIcon :: ImageMenuItem -> Maybe String -> IO ()
-setIcon _ Nothing = return ()
-setIcon item (Just iconName) = do
- iconTheme <- iconThemeGetDefault
- hasIcon <- iconThemeHasIcon iconTheme iconName
- mImg <- if hasIcon
- then return . Just =<< imageNewFromIconName iconName IconSizeMenu
- else if isAbsolute iconName
- then do ex <- doesFileExist iconName
- if ex
- then do let defaultSize = 24 -- FIXME should auto-adjust to font size
- pb <- pixbufNewFromFileAtScale iconName
- defaultSize defaultSize True
- return . Just =<< imageNewFromPixbuf pb
- else return Nothing
- else return Nothing
- case mImg of
- Just img -> imageMenuItemSetImage item img
- Nothing -> putStrLn $ "Icon not found: " ++ iconName
-
-
--- | Create a new XDG Menu Widget.
-menuWidgetNew :: Maybe String -- ^ menu name, must end with a dash,
- -- e.g. "mate-" or "gnome-"
- -> IO Widget
-menuWidgetNew mMenuPrefix = do
- mb <- menuBarNew
- m <- buildMenu mMenuPrefix
- addMenu mb m
- widgetShowAll mb
- return (toWidget mb)
-
--- -- | Show Xdg Menu Widget in a standalone frame.
--- testMenuWidget :: IO ()
--- testMenuWidget = do
--- _ <- initGUI
--- window <- windowNew
--- _ <- window `on` deleteEvent $ liftIO mainQuit >> return False
--- containerAdd window =<< menuWidgetNew Nothing
--- widgetShowAll window
--- mainGUI
diff --git a/src/System/Taffybar/Menu/XdgMenu.hs b/src/System/Taffybar/Menu/XdgMenu.hs
deleted file mode 100644
--- a/src/System/Taffybar/Menu/XdgMenu.hs
+++ /dev/null
@@ -1,277 +0,0 @@
-{-# OPTIONS_HADDOCK hide #-}
------------------------------------------------------------------------------
--- |
--- Module : System.Taffybar.Menu.XdgMenu
--- Copyright : 2017 Ulf Jasper
--- License : BSD3-style (see LICENSE)
---
--- Maintainer : Ulf Jasper
--- Stability : unstable
--- Portability : unportable
---
--- Implementation of version 1.1 of the XDG "Desktop Menu
--- Specification", see
--- https://specifications.freedesktop.org/menu-spec/menu-spec-1.1.html
----- specification, see
--- See also 'MenuWidget'.
---
------------------------------------------------------------------------------
-module System.Taffybar.Menu.XdgMenu (
- XdgMenu(..),
- DesktopEntryCondition(..),
- readXdgMenu,
- matchesCondition,
- getXdgDesktop,
- getDirectoryDirs,
- getApplicationEntries,
- getPreferredLanguages)
-where
-
-import Control.Applicative
-import Control.Monad.Trans
-import Control.Monad.Trans.Maybe
-import Data.Char (toLower)
-import Data.List
-import Data.Maybe
-import qualified Data.Set as S
-import qualified Debug.Trace as D
-import GHC.IO.Encoding
-import Prelude
-import Safe (headMay)
-import System.Directory
-import System.Environment
-import System.FilePath.Posix
-import System.Posix.Files
-import System.Taffybar.Menu.DesktopEntry
-import System.Taffybar.Util
-import Text.XML.Light
-import Text.XML.Light.Helpers
-
--- Environment Variables
-
--- | Produce a list of config locations to search, starting with
--- XDG_CONFIG_HOME and XDG_CONFIG_DIRS, with fallback to /etc/xdg
-getXdgConfigDirs :: IO [String]
-getXdgConfigDirs = do
- ch <- lookupEnv "XDG_CONFIG_HOME"
- cd <- lookupEnv "XDG_CONFIG_DIRS"
- let dirs = catMaybes [ch]
- ++ maybe [] splitSearchPath cd
- exDirs <- existingDirs dirs
- return $ if null exDirs
- then ["/etc/xdg/"]
- else map normalise exDirs
-
-existingDirs :: [FilePath] -> IO [FilePath]
-existingDirs dirs = do
- exs <- mapM fileExist dirs
- return $ S.toList $ S.fromList $ map fst $ filter snd $ zip dirs exs
-
-getXdgMenuPrefix :: IO (Maybe String)
-getXdgMenuPrefix = lookupEnv "XDG_MENU_PREFIX"
-
-getXdgDataDirs :: IO [String]
-getXdgDataDirs = do
- mDh <- lookupEnv "XDG_DATA_HOME"
- dh <- case mDh of
- Nothing -> do h <- getHomeDirectory
- return $ h ".local" "share"
- Just d -> return d
- mPf <- lookupEnv "XDG_DATA_DIRS"
- let dirs = maybe [] (map normalise . splitSearchPath) mPf
- ++ ["/usr/local/share", "/usr/share"]
- nubBy equalFilePath <$> existingDirs (dh:dirs)
-
--- | Find filename(s) of the application menu(s).
-getXdgMenuFilenames :: Maybe String
- -- ^ Overrides the value of the environment variable XDG_MENU_PREFIX.
- -- Specifies the prefix for the menu (e.g. 'Just "mate-"'). FIXME
- -> IO [FilePath]
-getXdgMenuFilenames mMenuPrefix = do
- configDirs <- getXdgConfigDirs
- maybePrefix <- (mMenuPrefix <|>) <$> getXdgMenuPrefix
- let maybeAddDash t = if last t == '-' then t else t ++ "-"
- dashedPrefix = maybe "" maybeAddDash maybePrefix
- return $ map ( "menus" dashedPrefix ++ "applications.menu") configDirs
-
--- | XDG Menu, cf. "Desktop Menu Specification".
-data XdgMenu = XdgMenu {
- xmAppDir :: Maybe String,
- xmDefaultAppDirs :: Bool, -- Use $XDG_DATA_DIRS/applications
- xmDirectoryDir :: Maybe String,
- xmDefaultDirectoryDirs :: Bool, -- Use $XDG_DATA_DIRS/desktop-directories
- xmLegacyDirs :: [String],
- xmName :: String,
- xmDirectory :: String,
- xmOnlyUnallocated :: Bool,
- xmDeleted :: Bool,
- xmInclude :: Maybe DesktopEntryCondition,
- xmExclude :: Maybe DesktopEntryCondition,
- xmSubmenus :: [XdgMenu],
- xmLayout :: [XdgLayoutItem]}
- deriving(Show)
-
-data XdgLayoutItem =
- XliFile String | XliSeparator | XliMenu String | XliMerge String
- deriving(Show)
-
--- | Return a list of all available desktop entries for a given xdg menu.
-getApplicationEntries :: [String] -- ^ Preferred languages
- -> XdgMenu
- -> IO [DesktopEntry]
-getApplicationEntries langs xm = do
- defEntries <- if xmDefaultAppDirs xm
- then do dataDirs <- getXdgDataDirs
- putStrLn $ "DataDirs=" ++ show dataDirs
- concat <$> mapM (listDesktopEntries ".desktop" .
- ( "applications")) dataDirs
- else return []
- return $ sortBy (\de1 de2 -> compare (map toLower (deName langs de1))
- (map toLower (deName langs de2))) defEntries
-
--- | Parse menu.
-parseMenu :: Element -> Maybe XdgMenu
-parseMenu elt =
- let appDir = getChildData "AppDir" elt
- defaultAppDirs = case getChildData "DefaultAppDirs" elt of
- Nothing -> False
- Just _ -> True
- directoryDir = getChildData "DirectoryDir" elt
- defaultDirectoryDirs = case getChildData "DefaultDirectoryDirs" elt of
- Nothing -> False
- Just _ -> True
- name = fromMaybe "Name?" $ getChildData "Name" elt
- dir = fromMaybe "Dir?" $ getChildData "Directory" elt
- onlyUnallocated = case (getChildData "OnlyUnallocated" elt,
- getChildData "NotOnlyUnallocated" elt) of
- (Nothing, Nothing) -> False -- ?!
- (Nothing, Just _) -> False
- (Just _, Nothing) -> True
- (Just _, Just _) -> False -- ?!
- deleted = False -- FIXME
- include = parseConditions "Include" elt
- exclude = parseConditions "Exclude" elt
- layout = parseLayout elt
- subMenus = fromMaybe [] $ mapChildren "Menu" elt parseMenu
- in Just XdgMenu {xmAppDir = appDir,
- xmDefaultAppDirs = defaultAppDirs,
- xmDirectoryDir = directoryDir,
- xmDefaultDirectoryDirs = defaultDirectoryDirs,
- xmLegacyDirs = [],
- xmName = name,
- xmDirectory = dir,
- xmOnlyUnallocated = onlyUnallocated,
- xmDeleted = deleted,
- xmInclude = include,
- xmExclude = exclude,
- xmSubmenus = subMenus,
- xmLayout = layout} -- FIXME
-
--- | Parse Desktop Entry conditions for Include/Exclude clauses.
-parseConditions :: String -> Element -> Maybe DesktopEntryCondition
-parseConditions key elt = case findChild (unqual key) elt of
- Nothing -> Nothing
- Just inc -> doParseConditions (elChildren inc)
- where doParseConditions :: [Element] -> Maybe DesktopEntryCondition
- doParseConditions [] = Nothing
- doParseConditions [e] = parseSingleItem e
- doParseConditions elts = Just $ Or $ mapMaybe parseSingleItem elts
-
- parseSingleItem e = case qName (elName e) of
- "Category" -> Just $ Category $ strContent e
- "Filename" -> Just $ Filename $ strContent e
- "And" -> Just $ And $ mapMaybe parseSingleItem
- $ elChildren e
- "Or" -> Just $ Or $ mapMaybe parseSingleItem
- $ elChildren e
- "Not" -> case parseSingleItem (head (elChildren e)) of
- Nothing -> Nothing
- Just rule -> Just $ Not rule
- unknown -> D.trace ("Unknown Condition item: " ++ unknown) Nothing
-
--- | Combinable conditions for Include and Exclude statements.
-data DesktopEntryCondition = Category String
- | Filename String
- | Not DesktopEntryCondition
- | And [DesktopEntryCondition]
- | Or [DesktopEntryCondition]
- | All
- | None
- deriving (Read, Show, Eq)
-
-parseLayout :: Element -> [XdgLayoutItem]
-parseLayout elt = case findChild (unqual "Layout") elt of
- Nothing -> []
- Just lt -> mapMaybe parseLayoutItem (elChildren lt)
- where parseLayoutItem :: Element -> Maybe XdgLayoutItem
- parseLayoutItem e = case qName (elName e) of
- "Separator" -> Just XliSeparator
- "Filename" -> Just $ XliFile $ strContent e
- unknown -> D.trace ("Unknown layout item: " ++ unknown) Nothing
-
--- | Determine whether a desktop entry fulfils a condition.
-matchesCondition :: DesktopEntry -> DesktopEntryCondition -> Bool
-matchesCondition de (Category cat) = deHasCategory de cat
-matchesCondition de (Filename fn) = fn == deFilename de
-matchesCondition de (Not cond) = not $ matchesCondition de cond
-matchesCondition de (And conds) = all (matchesCondition de) conds
-matchesCondition de (Or conds) = any (matchesCondition de) conds
-matchesCondition _ All = True
-matchesCondition _ None = False
-
--- | Determine locale language settings
-getPreferredLanguages :: IO [String]
-getPreferredLanguages = do
- mLcMessages <- lookupEnv "LC_MESSAGES"
- lang <- case mLcMessages of
- Nothing -> lookupEnv "LANG" -- FIXME?
- Just lm -> return (Just lm)
- case lang of
- Nothing -> return []
- Just l -> return $
- let woEncoding = takeWhile (/= '.') l
- (language, _cm) = span (/= '_') woEncoding
- (country, _m) = span (/= '@') (if null _cm then "" else tail _cm)
- modifier = if null _m then "" else tail _m
- in dgl language country modifier
- where dgl "" "" "" = []
- dgl l "" "" = [l]
- dgl l c "" = [l ++ "_" ++ c, l]
- dgl l "" m = [l ++ "@" ++ m, l]
- dgl l c m = [l ++ "_" ++ c ++ "@" ++ m, l ++ "_" ++ c,
- l ++ "@" ++ m]
-
--- | Determine current Desktop
-getXdgDesktop :: IO String
-getXdgDesktop = do
- mCurDt <- lookupEnv "XDG_CURRENT_DESKTOP"
- return $ fromMaybe "???" mCurDt
-
--- | Return desktop directories
-getDirectoryDirs :: IO [FilePath]
-getDirectoryDirs = do
- dataDirs <- getXdgDataDirs
- existingDirs $ map ( "desktop-directories") dataDirs
-
--- | Fetch menus and desktop entries and assemble the XDG menu.
-readXdgMenu :: Maybe String -> IO (Maybe (XdgMenu, [DesktopEntry]))
-readXdgMenu mMenuPrefix = do
- setLocaleEncoding utf8
- filenames <- getXdgMenuFilenames mMenuPrefix
- headMay . catMaybes <$> traverse maybeMenu filenames
-
--- | Load and assemble the XDG menu from a specific file, if it exists.
-maybeMenu :: FilePath -> IO (Maybe (XdgMenu, [DesktopEntry]))
-maybeMenu filename =
- ifM (doesFileExist filename)
- (do
- putStrLn $ "Reading " ++ filename
- contents <- readFile filename
- langs <- getPreferredLanguages
- runMaybeT $ do
- m <- MaybeT $ return $ parseXMLDoc contents >>= parseMenu
- des <- lift $ getApplicationEntries langs m
- return (m, des))
- (do
- putStrLn $ "Error: menu file '" ++ filename ++ "' does not exist!"
- return Nothing)
diff --git a/src/System/Taffybar/NetMonitor.hs b/src/System/Taffybar/NetMonitor.hs
deleted file mode 100644
--- a/src/System/Taffybar/NetMonitor.hs
+++ /dev/null
@@ -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.
--- 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
diff --git a/src/System/Taffybar/Pager.hs b/src/System/Taffybar/Pager.hs
deleted file mode 100644
--- a/src/System/Taffybar/Pager.hs
+++ /dev/null
@@ -1,200 +0,0 @@
------------------------------------------------------------------------------
--- |
--- Module : System.Taffybar.Pager
--- Copyright : (c) José A. Romero L.
--- License : BSD3-style (see LICENSE)
---
--- Maintainer : José A. Romero L.
--- 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 "%s" (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
diff --git a/src/System/Taffybar/PixbufCompat.hs b/src/System/Taffybar/PixbufCompat.hs
deleted file mode 100644
--- a/src/System/Taffybar/PixbufCompat.hs
+++ /dev/null
@@ -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
diff --git a/src/System/Taffybar/SimpleClock.hs b/src/System/Taffybar/SimpleClock.hs
deleted file mode 100644
--- a/src/System/Taffybar/SimpleClock.hs
+++ /dev/null
@@ -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
-
diff --git a/src/System/Taffybar/SimpleConfig.hs b/src/System/Taffybar/SimpleConfig.hs
new file mode 100644
--- /dev/null
+++ b/src/System/Taffybar/SimpleConfig.hs
@@ -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)
diff --git a/src/System/Taffybar/StrutProperties.hs b/src/System/Taffybar/StrutProperties.hs
deleted file mode 100644
--- a/src/System/Taffybar/StrutProperties.hs
+++ /dev/null
@@ -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)
-
diff --git a/src/System/Taffybar/Support/PagerHints.hs b/src/System/Taffybar/Support/PagerHints.hs
new file mode 100644
--- /dev/null
+++ b/src/System/Taffybar/Support/PagerHints.hs
@@ -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.
+-- 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
diff --git a/src/System/Taffybar/Systray.hs b/src/System/Taffybar/Systray.hs
deleted file mode 100644
--- a/src/System/Taffybar/Systray.hs
+++ /dev/null
@@ -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)
diff --git a/src/System/Taffybar/TaffyPager.hs b/src/System/Taffybar/TaffyPager.hs
deleted file mode 100644
--- a/src/System/Taffybar/TaffyPager.hs
+++ /dev/null
@@ -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.
--- 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
diff --git a/src/System/Taffybar/Text/CPUMonitor.hs b/src/System/Taffybar/Text/CPUMonitor.hs
deleted file mode 100644
--- a/src/System/Taffybar/Text/CPUMonitor.hs
+++ /dev/null
@@ -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"
diff --git a/src/System/Taffybar/Text/MemoryMonitor.hs b/src/System/Taffybar/Text/MemoryMonitor.hs
deleted file mode 100644
--- a/src/System/Taffybar/Text/MemoryMonitor.hs
+++ /dev/null
@@ -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
diff --git a/src/System/Taffybar/ToggleMonitor.hs b/src/System/Taffybar/ToggleMonitor.hs
deleted file mode 100644
--- a/src/System/Taffybar/ToggleMonitor.hs
+++ /dev/null
@@ -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
diff --git a/src/System/Taffybar/TransparentWindow.hs b/src/System/Taffybar/TransparentWindow.hs
new file mode 100644
--- /dev/null
+++ b/src/System/Taffybar/TransparentWindow.hs
@@ -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
diff --git a/src/System/Taffybar/Util.hs b/src/System/Taffybar/Util.hs
--- a/src/System/Taffybar/Util.hs
+++ b/src/System/Taffybar/Util.hs
@@ -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
diff --git a/src/System/Taffybar/Volume.hs b/src/System/Taffybar/Volume.hs
deleted file mode 100644
--- a/src/System/Taffybar/Volume.hs
+++ /dev/null
@@ -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
diff --git a/src/System/Taffybar/Weather.hs b/src/System/Taffybar/Weather.hs
deleted file mode 100644
--- a/src/System/Taffybar/Weather.hs
+++ /dev/null
@@ -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
---
---
---
--- 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
diff --git a/src/System/Taffybar/Widget.hs b/src/System/Taffybar/Widget.hs
new file mode 100644
--- /dev/null
+++ b/src/System/Taffybar/Widget.hs
@@ -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
diff --git a/src/System/Taffybar/Widget/Battery.hs b/src/System/Taffybar/Widget/Battery.hs
new file mode 100644
--- /dev/null
+++ b/src/System/Taffybar/Widget/Battery.hs
@@ -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)
diff --git a/src/System/Taffybar/Widget/CPUMonitor.hs b/src/System/Taffybar/Widget/CPUMonitor.hs
new file mode 100644
--- /dev/null
+++ b/src/System/Taffybar/Widget/CPUMonitor.hs
@@ -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.
+-- 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 []
diff --git a/src/System/Taffybar/Widget/CommandRunner.hs b/src/System/Taffybar/Widget/CommandRunner.hs
new file mode 100644
--- /dev/null
+++ b/src/System/Taffybar/Widget/CommandRunner.hs
@@ -0,0 +1,43 @@
+--------------------------------------------------------------------------------
+-- |
+-- Module : System.Taffybar.Widget.CommandRunner
+-- Copyright : (c) Arseniy Seroka
+-- License : BSD3-style (see LICENSE)
+--
+-- Maintainer : Arseniy Seroka
+-- 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
diff --git a/src/System/Taffybar/Widget/Decorators.hs b/src/System/Taffybar/Widget/Decorators.hs
new file mode 100644
--- /dev/null
+++ b/src/System/Taffybar/Widget/Decorators.hs
@@ -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
diff --git a/src/System/Taffybar/Widget/DiskIOMonitor.hs b/src/System/Taffybar/Widget/DiskIOMonitor.hs
new file mode 100644
--- /dev/null
+++ b/src/System/Taffybar/Widget/DiskIOMonitor.hs
@@ -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.
+-- 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
diff --git a/src/System/Taffybar/Widget/FSMonitor.hs b/src/System/Taffybar/Widget/FSMonitor.hs
new file mode 100644
--- /dev/null
+++ b/src/System/Taffybar/Widget/FSMonitor.hs
@@ -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.
+-- 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
diff --git a/src/System/Taffybar/Widget/FreedesktopNotifications.hs b/src/System/Taffybar/Widget/FreedesktopNotifications.hs
new file mode 100644
--- /dev/null
+++ b/src/System/Taffybar/Widget/FreedesktopNotifications.hs
@@ -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 "" <> prefix <> "" <> 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
diff --git a/src/System/Taffybar/Widget/Generic/ChannelGraph.hs b/src/System/Taffybar/Widget/Generic/ChannelGraph.hs
new file mode 100644
--- /dev/null
+++ b/src/System/Taffybar/Widget/Generic/ChannelGraph.hs
@@ -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
diff --git a/src/System/Taffybar/Widget/Generic/DynamicMenu.hs b/src/System/Taffybar/Widget/Generic/DynamicMenu.hs
new file mode 100644
--- /dev/null
+++ b/src/System/Taffybar/Widget/Generic/DynamicMenu.hs
@@ -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
diff --git a/src/System/Taffybar/Widget/Generic/Graph.hs b/src/System/Taffybar/Widget/Generic/Graph.hs
new file mode 100644
--- /dev/null
+++ b/src/System/Taffybar/Widget/Generic/Graph.hs
@@ -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)
diff --git a/src/System/Taffybar/Widget/Generic/Icon.hs b/src/System/Taffybar/Widget/Generic/Icon.hs
new file mode 100644
--- /dev/null
+++ b/src/System/Taffybar/Widget/Generic/Icon.hs
@@ -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 ()
diff --git a/src/System/Taffybar/Widget/Generic/PollingBar.hs b/src/System/Taffybar/Widget/Generic/PollingBar.hs
new file mode 100644
--- /dev/null
+++ b/src/System/Taffybar/Widget/Generic/PollingBar.hs
@@ -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)
diff --git a/src/System/Taffybar/Widget/Generic/PollingGraph.hs b/src/System/Taffybar/Widget/Generic/PollingGraph.hs
new file mode 100644
--- /dev/null
+++ b/src/System/Taffybar/Widget/Generic/PollingGraph.hs
@@ -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
diff --git a/src/System/Taffybar/Widget/Generic/PollingLabel.hs b/src/System/Taffybar/Widget/Generic/PollingLabel.hs
new file mode 100644
--- /dev/null
+++ b/src/System/Taffybar/Widget/Generic/PollingLabel.hs
@@ -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
diff --git a/src/System/Taffybar/Widget/Generic/VerticalBar.hs b/src/System/Taffybar/Widget/Generic/VerticalBar.hs
new file mode 100644
--- /dev/null
+++ b/src/System/Taffybar/Widget/Generic/VerticalBar.hs
@@ -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)
diff --git a/src/System/Taffybar/Widget/Layout.hs b/src/System/Taffybar/Widget/Layout.hs
new file mode 100644
--- /dev/null
+++ b/src/System/Taffybar/Widget/Layout.hs
@@ -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.
+-- 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)
diff --git a/src/System/Taffybar/Widget/MPRIS2.hs b/src/System/Taffybar/Widget/MPRIS2.hs
new file mode 100644
--- /dev/null
+++ b/src/System/Taffybar/Widget/MPRIS2.hs
@@ -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)
diff --git a/src/System/Taffybar/Widget/NetMonitor.hs b/src/System/Taffybar/Widget/NetMonitor.hs
new file mode 100644
--- /dev/null
+++ b/src/System/Taffybar/Widget/NetMonitor.hs
@@ -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.
+-- 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))
diff --git a/src/System/Taffybar/Widget/NetworkGraph.hs b/src/System/Taffybar/Widget/NetworkGraph.hs
new file mode 100644
--- /dev/null
+++ b/src/System/Taffybar/Widget/NetworkGraph.hs
@@ -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
diff --git a/src/System/Taffybar/Widget/SNITray.hs b/src/System/Taffybar/Widget/SNITray.hs
new file mode 100644
--- /dev/null
+++ b/src/System/Taffybar/Widget/SNITray.hs
@@ -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
diff --git a/src/System/Taffybar/Widget/SimpleClock.hs b/src/System/Taffybar/Widget/SimpleClock.hs
new file mode 100644
--- /dev/null
+++ b/src/System/Taffybar/Widget/SimpleClock.hs
@@ -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
+
diff --git a/src/System/Taffybar/Widget/Systray.hs b/src/System/Taffybar/Widget/Systray.hs
new file mode 100644
--- /dev/null
+++ b/src/System/Taffybar/Widget/Systray.hs
@@ -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)
diff --git a/src/System/Taffybar/Widget/Text/CPUMonitor.hs b/src/System/Taffybar/Widget/Text/CPUMonitor.hs
new file mode 100644
--- /dev/null
+++ b/src/System/Taffybar/Widget/Text/CPUMonitor.hs
@@ -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"
diff --git a/src/System/Taffybar/Widget/Text/MemoryMonitor.hs b/src/System/Taffybar/Widget/Text/MemoryMonitor.hs
new file mode 100644
--- /dev/null
+++ b/src/System/Taffybar/Widget/Text/MemoryMonitor.hs
@@ -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
diff --git a/src/System/Taffybar/Widget/Text/NetworkMonitor.hs b/src/System/Taffybar/Widget/Text/NetworkMonitor.hs
new file mode 100644
--- /dev/null
+++ b/src/System/Taffybar/Widget/Text/NetworkMonitor.hs
@@ -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
diff --git a/src/System/Taffybar/Widget/Util.hs b/src/System/Taffybar/Widget/Util.hs
new file mode 100644
--- /dev/null
+++ b/src/System/Taffybar/Widget/Util.hs
@@ -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.
+-- 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 "%s" (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
diff --git a/src/System/Taffybar/Widget/Volume.hs b/src/System/Taffybar/Widget/Volume.hs
new file mode 100644
--- /dev/null
+++ b/src/System/Taffybar/Widget/Volume.hs
@@ -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
diff --git a/src/System/Taffybar/Widget/Weather.hs b/src/System/Taffybar/Widget/Weather.hs
new file mode 100644
--- /dev/null
+++ b/src/System/Taffybar/Widget/Weather.hs
@@ -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
+--
+--
+--
+-- 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
diff --git a/src/System/Taffybar/Widget/Windows.hs b/src/System/Taffybar/Widget/Windows.hs
new file mode 100644
--- /dev/null
+++ b/src/System/Taffybar/Widget/Windows.hs
@@ -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
+-- 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
diff --git a/src/System/Taffybar/Widget/Workspaces.hs b/src/System/Taffybar/Widget/Workspaces.hs
new file mode 100644
--- /dev/null
+++ b/src/System/Taffybar/Widget/Workspaces.hs
@@ -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)
diff --git a/src/System/Taffybar/Widget/XDGMenu/Menu.hs b/src/System/Taffybar/Widget/XDGMenu/Menu.hs
new file mode 100644
--- /dev/null
+++ b/src/System/Taffybar/Widget/XDGMenu/Menu.hs
@@ -0,0 +1,136 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : System.Taffybar.Widget.XDGMenu.Menu
+-- Copyright : 2017 Ulf Jasper
+-- License : BSD3-style (see LICENSE)
+--
+-- Maintainer : Ulf Jasper
+-- Stability : unstable
+-- Portability : unportable
+--
+-- Implementation of version 1.1 of the freedesktop "Desktop Menu
+-- Specification", see
+-- https://specifications.freedesktop.org/menu-spec/menu-spec-1.1.html
+--
+-- See also 'MenuWidget'.
+-----------------------------------------------------------------------------
+
+module System.Taffybar.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
diff --git a/src/System/Taffybar/Widget/XDGMenu/MenuWidget.hs b/src/System/Taffybar/Widget/XDGMenu/MenuWidget.hs
new file mode 100644
--- /dev/null
+++ b/src/System/Taffybar/Widget/XDGMenu/MenuWidget.hs
@@ -0,0 +1,132 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : System.Taffybar.Widget.XDGMenu.MenuWidget
+-- Copyright : 2017 Ulf Jasper
+-- License : BSD3-style (see LICENSE)
+--
+-- Maintainer : Ulf Jasper
+-- Stability : unstable
+-- Portability : unportable
+--
+-- MenuWidget provides a hierachical GTK menu containing all
+-- applicable desktop entries found on the system. The menu is built
+-- according to the version 1.1 of the XDG "Desktop Menu
+-- Specification", see
+-- https://specifications.freedesktop.org/menu-spec/menu-spec-1.1.html
+-----------------------------------------------------------------------------
+
+module System.Taffybar.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
diff --git a/src/System/Taffybar/Widgets/Graph.hs b/src/System/Taffybar/Widgets/Graph.hs
deleted file mode 100644
--- a/src/System/Taffybar/Widgets/Graph.hs
+++ /dev/null
@@ -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)
diff --git a/src/System/Taffybar/Widgets/Icon.hs b/src/System/Taffybar/Widgets/Icon.hs
deleted file mode 100644
--- a/src/System/Taffybar/Widgets/Icon.hs
+++ /dev/null
@@ -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 ()
diff --git a/src/System/Taffybar/Widgets/PollingBar.hs b/src/System/Taffybar/Widgets/PollingBar.hs
deleted file mode 100644
--- a/src/System/Taffybar/Widgets/PollingBar.hs
+++ /dev/null
@@ -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
diff --git a/src/System/Taffybar/Widgets/PollingGraph.hs b/src/System/Taffybar/Widgets/PollingGraph.hs
deleted file mode 100644
--- a/src/System/Taffybar/Widgets/PollingGraph.hs
+++ /dev/null
@@ -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
diff --git a/src/System/Taffybar/Widgets/PollingLabel.hs b/src/System/Taffybar/Widgets/PollingLabel.hs
deleted file mode 100644
--- a/src/System/Taffybar/Widgets/PollingLabel.hs
+++ /dev/null
@@ -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)
-
diff --git a/src/System/Taffybar/Widgets/Util.hs b/src/System/Taffybar/Widgets/Util.hs
deleted file mode 100644
--- a/src/System/Taffybar/Widgets/Util.hs
+++ /dev/null
@@ -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.
--- 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)
diff --git a/src/System/Taffybar/Widgets/VerticalBar.hs b/src/System/Taffybar/Widgets/VerticalBar.hs
deleted file mode 100644
--- a/src/System/Taffybar/Widgets/VerticalBar.hs
+++ /dev/null
@@ -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)
diff --git a/src/System/Taffybar/WindowSwitcher.hs b/src/System/Taffybar/WindowSwitcher.hs
deleted file mode 100644
--- a/src/System/Taffybar/WindowSwitcher.hs
+++ /dev/null
@@ -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.
--- 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
diff --git a/src/System/Taffybar/WorkspaceHUD.hs b/src/System/Taffybar/WorkspaceHUD.hs
deleted file mode 100644
--- a/src/System/Taffybar/WorkspaceHUD.hs
+++ /dev/null
@@ -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)
diff --git a/src/gdk_property_change_wrapper.c b/src/gdk_property_change_wrapper.c
deleted file mode 100644
--- a/src/gdk_property_change_wrapper.c
+++ /dev/null
@@ -1,29 +0,0 @@
-////////////////////////////////////////////////////////////////////////////
-// Copyright : (c) Jan Vornberger 2009
-// License : BSD3-style (see LICENSE)
-//
-// Maintainer : jan.vornberger@informatik.uni-oldenburg.de
-////////////////////////////////////////////////////////////////////////////-
-
-#include
-#include
-#include
-
-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);
-}
diff --git a/taffybar.cabal b/taffybar.cabal
--- a/taffybar.cabal
+++ b/taffybar.cabal
@@ -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
diff --git a/taffybar.css b/taffybar.css
--- a/taffybar.css
+++ b/taffybar.css
@@ -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;
}
diff --git a/taffybar.hs.example b/taffybar.hs.example
--- a/taffybar.hs.example
+++ b/taffybar.hs.example
@@ -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 "%a %b %_d %H:%M" 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 ]
+ }