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)]
data PagerConfig = PagerConfig
{ activeWindow :: String -> String
, activeLayout :: String -> String
, activeLayoutIO :: String -> IO String
, activeWorkspace :: String -> String
, hiddenWorkspace :: String -> String
, emptyWorkspace :: String -> String
, visibleWorkspace :: String -> String
, urgentWorkspace :: String -> String
, widgetSep :: String
, workspaceBorder :: Bool
, workspaceGap :: Int
, workspacePad :: Bool
, useImages :: Bool
, imageSize :: Int
, fillEmptyImages :: Bool
, customIcon :: Bool -> String -> String -> Maybe FilePath
, windowSwitcherFormatter :: M.Map WorkspaceIdx String -> X11WindowHandle -> String
}
data Pager = Pager
{ config :: PagerConfig
, clients :: SubscriptionList
, 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
runReaderT prop x11Ctx
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
}
defaultFormatEntry
:: M.Map WorkspaceIdx String
-> X11WindowHandle
-> 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
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
notify :: Event -> (Listener, Filter) -> IO ()
notify event (listener, eventFilter) =
case event of
PropertyEvent _ _ _ _ _ atom _ _ ->
when (atom == eventFilter) $ catchAny (listener event) ignoreException
_ -> return ()
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 ()
colorize :: String
-> String
-> String
-> String
colorize fg bg = printf "<span%s%s>%s</span>" (attr "fg" fg) (attr "bg" bg)
where attr name value
| null value = ""
| otherwise = printf " %scolor=\"%s\"" name value
shorten :: Int -> String -> String
shorten l s
| length s <= l = s
| l >= 3 = take (l - 3) s ++ "..."
| otherwise = "..."
wrap :: String
-> String
-> String
-> String
wrap open close s = open ++ s ++ close
escape :: String -> String
escape = escapeMarkup