module System.Taffybar.WorkspaceSwitcher (
wspaceSwitcherNew
) where
import qualified Control.Concurrent.MVar as MV
import Control.Monad
import Control.Monad.IO.Class (MonadIO, liftIO)
import Data.List ((\\), findIndices)
import qualified Graphics.UI.Gtk as Gtk
import Graphics.X11.Xlib.Extras
import System.Taffybar.Pager
import System.Information.EWMHDesktopInfo
type Desktop = [Workspace]
data Workspace = Workspace { label :: Gtk.Label
, name :: String
, urgent :: Bool
}
wspaceSwitcherNew :: Pager -> IO Gtk.Widget
wspaceSwitcherNew pager = do
switcher <- Gtk.hBoxNew False 0
desktop <- getDesktop pager
deskRef <- MV.newMVar 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 $ Gtk.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 -> MV.MVar Desktop -> IO Bool
updateDesktop pager deskRef = do
wsnames <- withDefaultCtx getWorkspaceNames
MV.modifyMVar deskRef $ \desktop ->
case length wsnames /= length desktop of
True -> do
desk' <- getDesktop pager
return (desk', True)
False -> return (desktop, False)
populateSwitcher :: Gtk.BoxClass box => box -> MV.MVar Desktop -> IO ()
populateSwitcher switcher deskRef = do
containerClear switcher
desktop <- MV.readMVar deskRef
mapM_ (addButton switcher desktop) (allWorkspaces desktop)
Gtk.widgetShowAll switcher
activeCallback :: PagerConfig -> MV.MVar Desktop -> Event -> IO ()
activeCallback cfg deskRef _ = Gtk.postGUIAsync $ do
curr <- withDefaultCtx getVisibleWorkspaces
desktop <- MV.readMVar deskRef
case curr of
visible : _ | length desktop > visible -> do
when (urgent (desktop !! visible)) $ do
toggleUrgent deskRef visible False
transition cfg desktop curr
_ -> return ()
urgentCallback :: PagerConfig -> MV.MVar Desktop -> Event -> IO ()
urgentCallback cfg deskRef event = Gtk.postGUIAsync $ do
desktop <- MV.readMVar 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 :: Gtk.BoxClass box => Pager -> MV.MVar Desktop -> box -> Event -> IO ()
redrawCallback pager deskRef box _ = Gtk.postGUIAsync $ do
deskChanged <- updateDesktop pager deskRef
when deskChanged $ populateSwitcher box deskRef
containerClear :: Gtk.ContainerClass self => self -> IO ()
containerClear container = Gtk.containerForeach container (Gtk.containerRemove container)
toLabels :: [String] -> IO [Gtk.Label]
toLabels = mapM labelNewMarkup
where labelNewMarkup markup = do
lbl <- Gtk.labelNew (Nothing :: Maybe String)
Gtk.labelSetMarkup lbl markup
return lbl
addButton :: Gtk.BoxClass self
=> self
-> Desktop
-> Int
-> IO ()
addButton hbox desktop idx
| length desktop > idx = do
let index = desktop !! idx
lbl = label index
ebox <- Gtk.eventBoxNew
Gtk.widgetSetName ebox $ name index
Gtk.eventBoxSetVisibleWindow ebox False
_ <- Gtk.on ebox Gtk.buttonPressEvent $ switch idx
Gtk.containerAdd ebox lbl
Gtk.boxPackStart hbox ebox Gtk.PackNatural 0
| otherwise = return ()
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)
case wss of
active:rest -> do
mark desktop (activeWorkspace cfg) active
mapM_ (mark desktop $ visibleWorkspace cfg) rest
_ -> return ()
mapM_ (mark desktop $ urgentWorkspace cfg) urgentWs
mark :: Desktop
-> (String -> String)
-> Int
-> IO ()
mark desktop decorate idx
| length desktop > idx = do
let ws = desktop !! idx
Gtk.postGUIAsync $ Gtk.labelSetMarkup (label ws) $ decorate' (name ws)
| otherwise = return ()
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 :: MV.MVar Desktop
-> Int
-> Bool
-> IO ()
toggleUrgent deskRef idx isUrgent =
MV.modifyMVar_ deskRef $ \desktop -> do
let ws = desktop !! idx
case length desktop > idx of
True | isUrgent /= urgent ws -> do
let ws' = ws { urgent = isUrgent }
(ys, zs) = splitAt idx desktop
case zs of
_ : rest -> return $ ys ++ (ws' : rest)
_ -> return (ys ++ [ws'])
_ -> return desktop