module System.Taffybar.WorkspaceSwitcher (
wspaceSwitcherNew
) where
import Control.Applicative
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 Prelude
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_DESKTOP_NAMES"
subscribe pager redrawcb "_NET_NUMBER_OF_DESKTOPS"
subscribe pager urgentcb "WM_HINTS"
return $ Gtk.toWidget switcher
allWorkspaces :: Desktop -> [WorkspaceIdx]
allWorkspaces desktop = map WSIdx [0 .. length desktop 1]
nonEmptyWorkspaces :: IO [WorkspaceIdx]
nonEmptyWorkspaces = withDefaultCtx $ mapM getWorkspace =<< getWindows
getDesktop :: Pager -> IO Desktop
getDesktop pager = do
names <- map snd <$> 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 : _ | Just ws <- getWS desktop visible -> do
when (urgent ws) $ 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
getWS :: Desktop -> WorkspaceIdx -> Maybe Workspace
getWS desktop (WSIdx idx)
| length desktop > idx = Just (desktop !! idx)
| otherwise = Nothing
addButton :: Gtk.BoxClass self
=> self
-> Desktop
-> WorkspaceIdx
-> IO ()
addButton hbox desktop idx
| Just ws <- getWS desktop idx = do
let lbl = label ws
ebox <- Gtk.eventBoxNew
Gtk.widgetSetName ebox $ name ws
Gtk.eventBoxSetVisibleWindow ebox False
_ <- Gtk.on ebox Gtk.buttonPressEvent $ switch idx
_ <- Gtk.on ebox Gtk.scrollEvent $ do
dir <- Gtk.eventScrollDirection
case dir of
Gtk.ScrollUp -> switchOne True (length desktop 1)
Gtk.ScrollLeft -> switchOne True (length desktop 1)
Gtk.ScrollDown -> switchOne False (length desktop 1)
Gtk.ScrollRight -> switchOne False (length desktop 1)
Gtk.containerAdd ebox lbl
Gtk.boxPackStart hbox ebox Gtk.PackNatural 0
| otherwise = return ()
transition :: PagerConfig
-> Desktop
-> [WorkspaceIdx]
-> IO ()
transition cfg desktop wss = do
nonEmpty <- fmap (filter (>=WSIdx 0)) nonEmptyWorkspaces
let urgentWs = map WSIdx $ 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)
-> WorkspaceIdx
-> IO ()
mark desktop decorate wsIdx
| Just ws <- getWS desktop wsIdx =
Gtk.postGUIAsync $ Gtk.labelSetMarkup (label ws) $ decorate' (name ws)
| otherwise = return ()
where decorate' = pad . decorate
pad m | m == [] = m
| otherwise = ' ' : m
switch :: (MonadIO m) => WorkspaceIdx -> m Bool
switch idx = do
liftIO $ withDefaultCtx (switchToWorkspace idx)
return True
switchOne :: (MonadIO m) => Bool -> Int -> m Bool
switchOne dir end = do
liftIO $ withDefaultCtx (if dir then switchOneWorkspace dir end else switchOneWorkspace dir end)
return True
toggleUrgent :: MV.MVar Desktop
-> WorkspaceIdx
-> Bool
-> IO ()
toggleUrgent deskRef (WSIdx 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