----------------------------------------------------------------------------- -- | -- 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 , wrap , escape ) where import Control.Concurrent (forkIO) import Control.Exception import Control.Exception.Enclosed (catchAny) import Control.Monad.Reader import Data.IORef import qualified Data.Map as M import Graphics.UI.Gtk (escapeMarkup) import Graphics.X11.Types import Graphics.X11.Xlib.Extras hiding (rawGetWindowProperty, getWindowProperty8, getWindowProperty16, getWindowProperty32) import System.Information.EWMHDesktopInfo import System.Information.X11DesktopInfo import Text.Printf (printf) type Listener = Event -> IO () type Filter = Atom type SubscriptionList = IORef [(Listener, Filter)] -- | Structure contanining functions to customize the pretty printing of -- different widget elements. data PagerConfig = PagerConfig { 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. , clients :: SubscriptionList -- ^ functions to apply on incoming events depending on their types. , pagerX11ContextVar :: IORef X11Context } 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 <- readIORef $ pagerX11ContextVar pager -- runWithPager should probably changed so that it takes a default value 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 = do ref <- newIORef [] ctx <- getDefaultCtx ctxVar <- newIORef ctx let pager = Pager cfg ref ctxVar _ <- forkIO $ withDefaultCtx (eventLoop $ handleEvent ref) return pager where handleEvent :: SubscriptionList -> Event -> IO () handleEvent ref event = do listeners <- readIORef ref mapM_ (notify event) listeners -- | Passes the given Event to the given Listener, but only if it was -- registered for that type of events via 'subscribe'. notify :: Event -> (Listener, Filter) -> IO () notify event (listener, eventFilter) = case event of PropertyEvent _ _ _ _ _ atom _ _ -> when (atom == eventFilter) $ catchAny (listener event) ignoreException _ -> return () -- | Registers the given Listener as a subscriber of events of the given -- type: whenever a new event of the type with the given name arrives to -- the Pager, it will execute Listener on it. subscribe :: Pager -> Listener -> String -> IO () subscribe pager listener filterName = do eventFilter <- runWithPager pager $ getAtom filterName registered <- readIORef (clients pager) let next = (listener, eventFilter) writeIORef (clients pager) (next : registered) ignoreException :: SomeException -> IO () ignoreException _ = return () -- | 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