{-# LANGUAGE ScopedTypeVariables #-}
module System.Taffybar.WorkspaceSwitcher
{-# DEPRECATED "Use WorkspaceHUD instead of 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, sortBy)
import Data.Maybe (listToMaybe)
import Data.Ord (comparing)
import qualified Graphics.UI.Gtk as Gtk
import Graphics.X11.Xlib.Extras
import Prelude
import System.Taffybar.IconImages hiding (selectEWMHIcon)
import System.Taffybar.Pager
import System.Information.EWMHDesktopInfo
type Desktop = [Workspace]
data Workspace = Workspace { label :: Gtk.Label
, image :: Gtk.Image
, border :: Gtk.EventBox
, container :: Gtk.EventBox
, name :: String
, urgent :: Bool
}
type WindowSet = [(WorkspaceIdx, [X11Window])]
type WindowInfo = Maybe (String, String, [EWMHIcon])
type CustomIconF = Bool -> String -> String -> Maybe FilePath
type ImageChoice = (Maybe EWMHIcon, Maybe FilePath, Maybe ColorRGBA)
wspaceSwitcherNew :: Pager -> IO Gtk.Widget
wspaceSwitcherNew pager = do
switcher <- Gtk.hBoxNew False (workspaceGap (config pager))
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 activecb "_NET_WM_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
mapM (createWorkspace pager) names
createWorkspace :: Pager -> String -> IO Workspace
createWorkspace _pager wname = do
lbl <- createLabel wname
img <- Gtk.imageNew
brd <- Gtk.eventBoxNew
con <- Gtk.eventBoxNew
let useBorder = workspaceBorder (config _pager)
Gtk.eventBoxSetVisibleWindow brd useBorder
Gtk.containerSetBorderWidth con (if useBorder then 2 else 0)
return $ Workspace lbl img brd con wname False
updateDesktop :: Pager -> MV.MVar Desktop -> IO Bool
updateDesktop pager deskRef = do
wsnames <- withDefaultCtx getWorkspaceNames
MV.modifyMVar deskRef $ \desktop ->
case map snd wsnames /= map name 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
pad = if workspacePad cfg then prefixSpace else id
isUrgent <- isWindowUrgent window
when isUrgent $ do
this <- getCurrentWorkspace
that <- getWorkspace window
when (this /= that) $ liftIO $ do
toggleUrgent deskRef that True
mark desktop pad (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 c = Gtk.containerForeach c (Gtk.containerRemove c)
createLabel :: String -> IO Gtk.Label
createLabel 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 switcherHbox desktop idx
| Just ws <- getWS desktop idx = do
let lbl = label ws
let img = image ws
let brd = border ws
let con = container ws
btnParentEbox <- Gtk.eventBoxNew
iconLabelBox <- Gtk.hBoxNew False 0
Gtk.boxPackStart switcherHbox btnParentEbox Gtk.PackNatural 0
Gtk.containerAdd btnParentEbox brd
Gtk.containerAdd brd con
Gtk.containerAdd con iconLabelBox
Gtk.containerAdd iconLabelBox lbl
Gtk.containerAdd iconLabelBox img
Gtk.widgetSetName btnParentEbox $ name ws
Gtk.eventBoxSetVisibleWindow btnParentEbox False
_ <- Gtk.on btnParentEbox Gtk.buttonPressEvent $ switch idx
_ <- Gtk.on btnParentEbox 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.ScrollSmooth -> return False
return ()
| 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
pad = if workspacePad cfg then prefixSpace else id
mapM_ (mark desktop pad $ hiddenWorkspace cfg) nonEmptyWs
mapM_ (setWidgetNames desktop "hidden") nonEmptyWs
mapM_ (mark desktop pad $ emptyWorkspace cfg) (allWs \\ nonEmpty)
mapM_ (setWidgetNames desktop "empty") (allWs \\ nonEmpty)
case wss of
active:rest -> do
mark desktop pad (activeWorkspace cfg) active
setWidgetNames desktop "active" active
mapM_ (mark desktop pad $ visibleWorkspace cfg) rest
mapM_ (setWidgetNames desktop "visible") rest
_ -> return ()
mapM_ (mark desktop pad $ urgentWorkspace cfg) urgentWs
mapM_ (setWidgetNames desktop "urgent") urgentWs
let useImg = useImages cfg
fillEmpty = fillEmptyImages cfg
imgSize = imageSize cfg
customIconF = customIcon cfg
when useImg $ updateImages desktop imgSize fillEmpty customIconF
updateImages :: Desktop -> Int -> Bool -> CustomIconF -> IO ()
updateImages desktop imgSize fillEmpty customIconF = do
windowSet <- getWindowSet (allWorkspaces desktop)
lastWinInfo <- getLastWindowInfo windowSet
let images = map image desktop
fillColor = if fillEmpty then Just (0, 0, 0, 0) else Nothing
imageChoices = getImageChoices lastWinInfo customIconF fillColor imgSize
zipWithM_ (setImage imgSize) images imageChoices
getImageChoices :: [WindowInfo] -> CustomIconF -> Maybe ColorRGBA -> Int -> [ImageChoice]
getImageChoices lastWinInfo customIconF fillColor imgSize = zip3 icons files colors
where icons = map (selectEWMHIcon imgSize) lastWinInfo
files = map (selectCustomIconFile customIconF) lastWinInfo
colors = map (\_ -> fillColor) lastWinInfo
selectEWMHIcon :: Int -> WindowInfo -> Maybe EWMHIcon
selectEWMHIcon imgSize (Just (_, _, icons)) = listToMaybe prefIcon
where sortedIcons = sortOn height icons
smallestLargerIcon = take 1 $ dropWhile ((<=imgSize).height) sortedIcons
largestIcon = take 1 $ reverse sortedIcons
prefIcon = smallestLargerIcon ++ largestIcon
sortOn f = sortBy (comparing f)
selectEWMHIcon _ _ = Nothing
selectCustomIconFile :: CustomIconF -> WindowInfo -> Maybe FilePath
selectCustomIconFile customIconF (Just (wTitle, wClass, icons)) = customIconF (length icons > 0) wTitle wClass
selectCustomIconFile _ _ = Nothing
setImage :: Int -> Gtk.Image -> ImageChoice -> IO ()
setImage imgSize img imgChoice = setImgAct imgChoice
where setImgAct (_, Just file, _) = setImageFromFile img imgSize file
setImgAct (Just icon, _, _) = setImageFromEWMHIcon img imgSize icon
setImgAct (_, _, Just color) = setImageFromColor img imgSize color
setImgAct _ = Gtk.imageClear img
setImageFromEWMHIcon :: Gtk.Image -> Int -> EWMHIcon -> IO ()
setImageFromEWMHIcon img imgSize icon = do
pixbuf <- pixBufFromEWMHIcon icon
scaledPixbuf <- scalePixbuf imgSize pixbuf
Gtk.imageSetFromPixbuf img scaledPixbuf
setImageFromFile :: Gtk.Image -> Int -> FilePath -> IO ()
setImageFromFile img imgSize file = do
pixbuf <- Gtk.pixbufNewFromFileAtScale file imgSize imgSize False
scaledPixbuf <- scalePixbuf imgSize pixbuf
Gtk.imageSetFromPixbuf img scaledPixbuf
setImageFromColor :: Gtk.Image -> Int -> ColorRGBA -> IO ()
setImageFromColor img imgSize (r,g,b,a) = do
let sampleBits = 8
hasAlpha = True
colorspace = Gtk.ColorspaceRgb
pixbuf <- Gtk.pixbufNew colorspace hasAlpha sampleBits imgSize imgSize
Gtk.pixbufFill pixbuf r g b a
scaledPixbuf <- scalePixbuf imgSize pixbuf
Gtk.imageSetFromPixbuf img scaledPixbuf
getLastWindowInfo :: WindowSet -> IO [WindowInfo]
getLastWindowInfo windowSet = mapM getWindowInfo lastWins
where wsIdxs = map fst windowSet
lastWins = map lastWin wsIdxs
wins wsIdx = snd $ head $ filter ((==wsIdx).fst) windowSet
lastWin wsIdx = listToMaybe $ reverse $ wins wsIdx
getWindowInfo :: Maybe X11Window -> IO WindowInfo
getWindowInfo Nothing = return Nothing
getWindowInfo (Just w) = withDefaultCtx $ do
wTitle <- getWindowTitle w
wClass <- getWindowClass w
wIcon <- getWindowIcons w
return $ Just (wTitle, wClass, wIcon)
getWindowSet :: [WorkspaceIdx] -> IO WindowSet
getWindowSet wsIdxs = do
windows <- withDefaultCtx getWindows
workspaces <- mapM (withDefaultCtx.getWorkspace) windows
let wsWins = zip workspaces windows
return $ map (\wsIdx -> (wsIdx, lookupAll wsIdx wsWins)) wsIdxs
where lookupAll x xs = map snd $ filter (((==)x).fst) xs
mark :: Desktop
-> (String -> String)
-> (String -> String)
-> WorkspaceIdx
-> IO ()
mark desktop pad decorate wsIdx
| Just ws <- getWS desktop wsIdx =
Gtk.postGUIAsync $ Gtk.labelSetMarkup (label ws) $ pad $ decorate (name ws)
| otherwise = return ()
prefixSpace :: String -> String
prefixSpace "" = ""
prefixSpace s = " " ++ s
setWidgetNames :: Desktop -> String -> WorkspaceIdx -> IO ()
setWidgetNames desktop workspaceState wsIdx
| Just ws <- getWS desktop wsIdx = do
Gtk.widgetSetName (label ws) (widgetName "Label" (name ws))
Gtk.widgetSetName (image ws) (widgetName "Image" (name ws))
Gtk.widgetSetName (border ws) (widgetName "Border" (name ws))
Gtk.widgetSetName (container ws) (widgetName "Container" (name ws))
| otherwise = return ()
where widgetName widget wsName = "Workspace"
++ "-" ++ widget
++ "-" ++ wsName
++ "-" ++ workspaceState
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