module System.Taffybar.WorkspaceSwitcher (
wspaceSwitcherNew
) where
import Control.Monad
import Control.Monad.IO.Class (MonadIO, liftIO)
import Data.IORef
import Data.List ((\\), findIndices)
import Graphics.UI.Gtk hiding (get)
import Graphics.X11.Xlib.Extras
import System.Taffybar.Pager
import System.Information.EWMHDesktopInfo
type Desktop = [Workspace]
data Workspace = Workspace { label :: Label
, name :: String
, urgent :: Bool
}
wspaceSwitcherNew :: Pager -> IO Widget
wspaceSwitcherNew pager = do
switcher <- hBoxNew False 0
desktop <- getDesktop pager
deskRef <- newIORef desktop
populateSwitcher switcher deskRef
let cfg = config pager
activecb = activeCallback cfg deskRef
redrawcb = redrawCallback pager deskRef switcher
urgentcb = urgentCallback cfg deskRef
subscribe pager activecb "_NET_CURRENT_DESKTOP"
subscribe pager redrawcb "_NET_NUMBER_OF_DESKTOPS"
subscribe pager urgentcb "WM_HINTS"
return $ toWidget switcher
allWorkspaces :: Desktop -> [Int]
allWorkspaces desktop = [0 .. length desktop 1]
nonEmptyWorkspaces :: IO [Int]
nonEmptyWorkspaces = withDefaultCtx $ mapM getWorkspace =<< getWindows
getDesktop :: Pager -> IO Desktop
getDesktop pager = do
names <- withDefaultCtx getWorkspaceNames
labels <- toLabels $ map (hiddenWorkspace $ config pager) names
return $ zipWith (\n l -> Workspace l n False) names labels
updateDesktop :: Pager -> IORef Desktop -> IO Bool
updateDesktop pager deskRef = do
wsnames <- withDefaultCtx getWorkspaceNames
desktop <- readIORef deskRef
if (length wsnames /= length desktop)
then getDesktop pager >>= writeIORef deskRef >> return True
else return False
populateSwitcher :: BoxClass box => box -> IORef Desktop -> IO ()
populateSwitcher switcher deskRef = do
containerClear switcher
desktop <- readIORef deskRef
mapM_ (addButton switcher desktop) (allWorkspaces desktop)
widgetShowAll switcher
activeCallback :: PagerConfig -> IORef Desktop -> Event -> IO ()
activeCallback cfg deskRef _ = do
curr <- withDefaultCtx getVisibleWorkspaces
desktop <- readIORef deskRef
let visible = head curr
when (urgent $ desktop !! visible) $
liftIO $ toggleUrgent deskRef visible False
transition cfg desktop curr
urgentCallback :: PagerConfig -> IORef Desktop -> Event -> IO ()
urgentCallback cfg deskRef event = do
desktop <- readIORef deskRef
withDefaultCtx $ do
let window = ev_window event
isUrgent <- isWindowUrgent window
when isUrgent $ do
this <- getCurrentWorkspace
that <- getWorkspace window
when (this /= that) $ liftIO $ do
toggleUrgent deskRef that True
mark desktop (urgentWorkspace cfg) that
redrawCallback :: BoxClass box => Pager -> IORef Desktop -> box -> Event -> IO ()
redrawCallback pager deskRef box _ =
updateDesktop pager deskRef >>= \deskChanged ->
when deskChanged $ postGUIAsync (populateSwitcher box deskRef)
containerClear :: ContainerClass self => self -> IO ()
containerClear container = containerForeach container (containerRemove container)
toLabels :: [String] -> IO [Label]
toLabels = mapM labelNewMarkup
where labelNewMarkup markup = do
lbl <- labelNew (Nothing :: Maybe String)
labelSetMarkup lbl markup
return lbl
addButton :: BoxClass self
=> self
-> Desktop
-> Int
-> IO ()
addButton hbox desktop idx = do
let index = desktop !! idx
lbl = label index
ebox <- eventBoxNew
widgetSetName ebox $ name index
eventBoxSetVisibleWindow ebox False
_ <- on ebox buttonPressEvent $ switch idx
containerAdd ebox lbl
boxPackStart hbox ebox PackNatural 0
transition :: PagerConfig
-> Desktop
-> [Int]
-> IO ()
transition cfg desktop wss = do
nonEmpty <- fmap (filter (>=0)) nonEmptyWorkspaces
let urgentWs = findIndices urgent desktop
allWs = (allWorkspaces desktop) \\ urgentWs
nonEmptyWs = nonEmpty \\ urgentWs
mapM_ (mark desktop $ hiddenWorkspace cfg) nonEmptyWs
mapM_ (mark desktop $ emptyWorkspace cfg) (allWs \\ nonEmpty)
mark desktop (activeWorkspace cfg) (head wss)
mapM_ (mark desktop $ visibleWorkspace cfg) (tail wss)
mapM_ (mark desktop $ urgentWorkspace cfg) urgentWs
mark :: Desktop
-> (String -> String)
-> Int
-> IO ()
mark desktop decorate idx = do
let ws = desktop !! idx
postGUIAsync $ labelSetMarkup (label ws) $ decorate' (name ws)
where decorate' = pad . decorate
pad m | m == [] = m
| otherwise = ' ' : m
switch :: (MonadIO m) => Int -> m Bool
switch idx = do
liftIO $ withDefaultCtx (switchToWorkspace idx)
return True
toggleUrgent :: IORef Desktop
-> Int
-> Bool
-> IO ()
toggleUrgent deskRef idx isUrgent = do
desktop <- readIORef deskRef
let ws = desktop !! idx
unless (isUrgent == urgent ws) $ do
let ws' = (desktop !! idx) { urgent = isUrgent }
let (ys, zs) = splitAt idx desktop
in writeIORef deskRef $ ys ++ (ws' : tail zs)