phi/lib/Phi/Widgets/Taskbar.hs

{-# LANGUAGE TypeFamilies, DeriveDataTypeable, TypeSynonymInstances #-}

module Phi.Widgets.Taskbar ( IconStyle
                           , idIconStyle
                           , desaturateIconStyle
                           , TaskStyle(..)
                           , TaskbarConfig(..)
                           , defaultTaskbarConfig
                           , taskbar
                           ) where

import Control.Concurrent
import Control.Monad
import Control.Monad.State
import Control.Monad.Trans

import Data.Array.MArray
import Data.Bits
import Data.Char
import Data.Function
import Data.List
import Data.Maybe
import Data.Typeable
import Data.Word
import qualified Data.Map as M

import Foreign.C.Types

import Graphics.Rendering.Cairo
import Graphics.Rendering.Pango.Cairo
import Graphics.Rendering.Pango.Enums (PangoRectangle(..))
import Graphics.Rendering.Pango.Layout
import Graphics.Rendering.Pango.Font

import Graphics.X11.Xlib (Window)
import qualified Graphics.X11.Xlib as Xlib
import qualified Graphics.X11.Xlib.Extras as XExtras

import Codec.Binary.UTF8.String

import Phi.Phi
import Phi.Types
import Phi.Border
import Phi.Widget
import Phi.X11.Atoms


type IconStyle = Surface -> Render ()
instance Show IconStyle where
  show _ = "IconStyle"

idIconStyle :: IconStyle
idIconStyle = flip withPatternForSurface setSource

desaturateIconStyle :: Double -> IconStyle
desaturateIconStyle v icon = do
  w <- imageSurfaceGetWidth icon
  h <- imageSurfaceGetHeight icon
  
  renderWithSimilarSurface ContentColorAlpha w h $ \surface1 -> do
    renderWithSimilarSurface ContentColor w h $ \surface2 -> do
      renderWith surface1 $ do
        renderWith surface2 $ do
          withPatternForSurface icon setSource
          paint
          
          setOperator OperatorHslSaturation
          setSourceRGBA 0 0 0 (1-v)
          paint
        
        withPatternForSurface surface2 setSource
        paint
        
        setOperator OperatorDestIn
        withPatternForSurface icon setSource
        paint
    
      withPatternForSurface surface1 setSource

data TaskStyle = TaskStyle { taskFont      :: !String
                           , taskColor     :: !Color
                           , taskBorder    :: !BorderConfig
                           , taskIconStyle :: !IconStyle
                           } deriving Show

data TaskbarConfig = TaskbarConfig { taskMaxSize      :: !Int
                                   , showDesktops     :: !Bool
                                   , normalTaskStyle  :: !TaskStyle
                                   , activeTaskStyle  :: !TaskStyle
                                   } deriving Show

defaultStyle :: TaskStyle
defaultStyle = TaskStyle { taskFont = "Sans 8"
                         , taskColor = (0, 0, 0, 1)
                         , taskBorder = defaultBorderConfig
                         , taskIconStyle = idIconStyle
                         }

defaultTaskbarConfig :: TaskbarConfig
defaultTaskbarConfig = TaskbarConfig { taskMaxSize = 150
                                     , showDesktops = False
                                     , normalTaskStyle = defaultStyle
                                     , activeTaskStyle = defaultStyle {taskBorder = defaultBorderConfig { borderColor = (1, 1, 1, 1) }}
                                     }

data Taskbar = Taskbar TaskbarConfig deriving Show

instance Show Surface where
  show _ = "Surface <?>"

data TaskbarState = TaskbarState { taskbarActiveWindow :: !Window
                                 , taskbarDesktopCount :: !Int
                                 , taskbarWindows      :: ![Window]
                                 , taskbarWindowStates :: !(M.Map Window WindowState)
                                 , taskbarWindowIcons ::  !(M.Map Window [(Int, Surface)])
                                 } deriving Show

data WindowState = WindowState { windowTitle   :: !String
                               , windowDesktop :: !Int
                               , windowVisible :: !Bool
                               } deriving (Show, Eq)

data TaskbarMessage = WindowListUpdate [Xlib.Window] (M.Map Window WindowState) (M.Map Window [(Int, Surface)])
                    | DesktopCountUpdate Int
                    | ActiveWindowUpdate Window
                    deriving (Show, Typeable)

instance WidgetClass Taskbar where
  type WidgetData Taskbar = TaskbarState
  
  initWidget (Taskbar _) phi dispvar = do
    forkIO $ taskbarRunner phi dispvar
    
    return $ TaskbarState 0 0 [] M.empty M.empty

    
  minSize _ = 0
  weight _ = 1
  
  render (Taskbar config) TaskbarState { taskbarActiveWindow = activeWindow
                                       , taskbarDesktopCount = desktopCount
                                       , taskbarWindows = windows
                                       , taskbarWindowStates = windowStates
                                       , taskbarWindowIcons = windowIcons
                                       } w h = do
    let desktopWindows = map (\desktop -> (desktop, filter (fromMaybe False . fmap (windowOnDesktop desktop) . flip M.lookup windowStates) windows)) $ take desktopCount [0..]
        windowCount = sum $ map (length . snd) $ desktopWindows
    when (windowCount /= 0) $ do
      let windowWidth = min (taskMaxSize config) (w `div` windowCount)
      
      forM_ (zip [0..] $ join $ map snd desktopWindows) $ \(i, window) -> do
        let style = (if window == activeWindow then activeTaskStyle else normalTaskStyle) config
            (r, g, b, a) = taskColor style
            leftBorder = (borderLeft $ margin $ taskBorder style) + (borderWidth $ taskBorder style) + (borderLeft $ padding $ taskBorder style)
            rightBorder = (borderRight $ margin $ taskBorder style) + (borderWidth $ taskBorder style) + (borderRight $ padding $ taskBorder style)
            h' = h - (borderV $ margin $ taskBorder style)
            mstate = M.lookup window windowStates
            micons = M.lookup window windowIcons

        case (mstate, micons) of
          (Just state, Just icons) -> do
            save
            drawBorder (taskBorder style) (i*windowWidth) 0 windowWidth h
            clip
            
            setSourceRGBA r g b a
            renderText style (fromIntegral (i*windowWidth + leftBorder + h' + 3)) 0 (windowWidth - leftBorder - h' - 3 - rightBorder) h $ windowTitle state
            
            restore
            
            case bestIcon h' icons of
              Just icon -> do 
                save
                translate (fromIntegral $  i*windowWidth + leftBorder) (fromIntegral $ borderTop $ margin $ taskBorder style)
                imageW <- imageSurfaceGetWidth icon
                imageH <- imageSurfaceGetHeight icon
                
                let scalef = (fromIntegral h')/(fromIntegral $ max imageW imageH)
                scale scalef scalef
                
                when (imageH < imageW) $
                  translate 0 $ (fromIntegral (imageW-imageH))/2
                
                taskIconStyle style icon
                paint
                restore
                
              Nothing -> return ()
          
          _ -> return ()
        
  
  handleMessage _ priv m = case (fromMessage m) of
    Just (WindowListUpdate windows windowStates icons) -> priv {taskbarWindows = windows, taskbarWindowStates = windowStates, taskbarWindowIcons = icons}
    Just (DesktopCountUpdate count) -> priv {taskbarDesktopCount = count}
    Just (ActiveWindowUpdate window) -> priv {taskbarActiveWindow = window}
    _ -> priv


renderText :: TaskStyle -> Int -> Int -> Int -> Int -> String -> Render ()
renderText style x y w h text = do
  layout <- createLayout ""
  (_, PangoRectangle _ _ textWidth textHeight) <- liftIO $ do
    layoutSetMarkup layout $ "<span font='" ++ (taskFont style) ++ "'>" ++ (escapeMarkup text) ++ "</span>"
    layoutSetWidth layout $ Just $ fromIntegral w
    layoutSetEllipsize layout EllipsizeEnd
    
    layoutGetExtents layout
  
  
  moveTo ((fromIntegral x) + ((fromIntegral w) - textWidth)/2) ((fromIntegral y) + ((fromIntegral h) - textHeight)/2)
  showLayout layout

bestIcon :: Int -> [(Int, Surface)] -> Maybe Surface
bestIcon h icons = findBest $ sortBy compareIcons icons
  where
    compareIcons = flip (compare `on` fst)
    
    findBest (a1:a2:ax) = if (fst a2) < h then Just $ snd a1 else findBest (a2:ax)
    findBest [a] = Just $ snd a
    findBest [] = Nothing


windowOnDesktop :: Int -> WindowState -> Bool
windowOnDesktop desktop state = (windowVisible state) && (desktop == windowDesktop state)


taskbarRunner :: Phi -> Display -> IO ()
taskbarRunner phi dispvar = do
  (windows, states, icons) <- liftIO $ withDisplay dispvar $ \disp -> do
    (windows, states, icons) <- getWindowStates disp (getAtoms dispvar) [] M.empty M.empty
    desktopCount <- getDesktopCount disp (getAtoms dispvar) 
    activeWindow <- getActiveWindow disp (getAtoms dispvar) 
    sendMessage phi $ WindowListUpdate windows states icons
    sendMessage phi $ DesktopCountUpdate desktopCount
    sendMessage phi $ ActiveWindowUpdate activeWindow
    return (windows, states, icons)
  sendMessage phi Repaint
  
  flip evalStateT (windows, states, icons) $ forever $ do
    m <- receiveMessage phi
    case (fromMessage m) of
      Just event@XExtras.PropertyEvent {} -> 
        handlePropertyUpdate phi dispvar event
      _ ->
        return ()

handlePropertyUpdate :: Phi -> Display -> XExtras.Event -> StateT ([Window], M.Map Window WindowState, M.Map Window [(Int, Surface)]) IO ()
handlePropertyUpdate phi dispvar XExtras.PropertyEvent {XExtras.ev_atom = atom, XExtras.ev_window = window} = do
  let atoms = getAtoms dispvar
  
  when (elem atom $ map ($ atoms) [ atom_NET_ACTIVE_WINDOW
                                  , atom_NET_NUMBER_OF_DESKTOPS
                                  , atom_NET_CLIENT_LIST
                                  , atom_NET_WM_ICON
                                  , atom_NET_WM_NAME
                                  , atomWM_NAME
                                  , atom_NET_WM_DESKTOP
                                  , atom_NET_WM_STATE
                                  ]) $ withDisplay dispvar $ \disp -> do
    let rootwin = Xlib.defaultRootWindow disp
    if (window == rootwin)
      then do
      when (atom == atom_NET_ACTIVE_WINDOW atoms) $ do
        activeWindow <- liftIO $ getActiveWindow disp atoms
        sendMessage phi $ ActiveWindowUpdate activeWindow
        sendMessage phi Repaint
      when (atom == atom_NET_NUMBER_OF_DESKTOPS atoms) $ do
        desktopCount <- liftIO $ getDesktopCount disp atoms
        sendMessage phi $ DesktopCountUpdate desktopCount
        sendMessage phi Repaint
      when (atom == atom_NET_CLIENT_LIST atoms) $ do
        (windows, windowStates, icons) <- get
        (windows', windowStates', icons') <- liftIO $ getWindowStates disp atoms windows windowStates icons
        
        when (windows /= windows') $ do
          sendMessage phi $ WindowListUpdate windows' windowStates' icons'
          sendMessage phi Repaint
          put (windows', windowStates', icons')
    
      else do
      (windows, windowStates, icons) <- get
      when (elem window windows) $ do
        when (atom == atom_NET_WM_ICON atoms) $ do
          icon <- liftIO $ getWindowIcons disp atoms window
          let icons' = M.insert window icon icons
          sendMessage phi $ WindowListUpdate windows windowStates icons'
          sendMessage phi Repaint
          put (windows, windowStates, icons')
        
        when (atom /= atom_NET_WM_ICON atoms) $ do
          let windowState = M.lookup window windowStates
          windowState' <- liftIO $ getWindowState disp atoms window
          
          when (windowState /= (Just windowState')) $ do
            let windowStates' = M.insert window windowState' windowStates
            sendMessage phi $ WindowListUpdate windows windowStates' icons
            sendMessage phi Repaint
            put (windows, windowStates', icons)

getDesktopCount :: Xlib.Display -> Atoms -> IO Int
getDesktopCount disp atoms =
  liftM (fromIntegral . fromMaybe 0 . join . fmap listToMaybe) $ XExtras.getWindowProperty32 disp (atom_NET_NUMBER_OF_DESKTOPS atoms) $ Xlib.defaultRootWindow disp

getActiveWindow :: Xlib.Display -> Atoms -> IO Window
getActiveWindow disp atoms =
  liftM (fromIntegral . fromMaybe 0 . join . fmap listToMaybe) $ XExtras.getWindowProperty32 disp (atom_NET_ACTIVE_WINDOW atoms) $ Xlib.defaultRootWindow disp

getWindowStates :: Xlib.Display -> Atoms -> [Window] -> M.Map Window WindowState -> M.Map Window [(Int, Surface)]
                   -> IO ([Window], M.Map Window WindowState, M.Map Window [(Int, Surface)])
getWindowStates disp atoms oldWindows windowStates windowIcons = do
  windows <- getWindowList disp atoms oldWindows
  
  let windowStates' = map (\w -> (w, M.lookup w windowStates)) windows
      windowIcons' = map (\w -> (w, M.lookup w windowIcons)) windows
  
  newWindowStates <- mapM getWindowState' windowStates'
  newWindowIcons <- mapM getWindowIcons' windowIcons'
  
  return (windows, M.fromList newWindowStates, M.fromList newWindowIcons)
    where
      getWindowState' (window, Just windowState) = return (window, windowState) 
      getWindowState' (window, Nothing) = do
        windowState <- getWindowState disp atoms window
        return (window, windowState)
      
      getWindowIcons' (window, Just icons) = return (window, icons)
      getWindowIcons' (window, Nothing) = do
        icons <- getWindowIcons disp atoms window
        return (window, icons)

getWindowState :: Xlib.Display -> Atoms -> Window -> IO WindowState
getWindowState disp atoms window = do
  Xlib.selectInput disp window Xlib.propertyChangeMask
  netwmname <- liftM (fmap (decode . map fromIntegral)) $ XExtras.getWindowProperty8 disp (atom_NET_WM_NAME atoms) window
  wmname <- case netwmname of
    Just name -> return name
    Nothing -> liftM (map unsignedChr . fromMaybe []) $ XExtras.getWindowProperty8 disp (atomWM_NAME atoms) window
  
  workspace <- liftM (fromIntegral . fromMaybe 0xFFFFFFFF . join . fmap listToMaybe) $ XExtras.getWindowProperty32 disp (atom_NET_WM_DESKTOP atoms) window
  
  visible <- showWindow disp atoms window
  
  return $ WindowState wmname workspace visible
    where
      unsignedChr = chr . fromIntegral . (fromIntegral :: (CChar -> CUChar))

getWindowIcons :: Xlib.Display -> Atoms -> Window -> IO [(Int, Surface)]
getWindowIcons disp atoms window = XExtras.getWindowProperty32 disp (atom_NET_WM_ICON atoms) window >>= readIcons . fromMaybe []

readIcons :: [CLong] -> IO [(Int, Surface)]
readIcons (width:height:iconData) = do
  if ((fromIntegral $ length iconData) < (width*height)) then return [] else do
    let (thisIcon, rest) = splitAt (fromIntegral (width*height)) iconData
    icon <- createImageSurface FormatARGB32 (fromIntegral width) (fromIntegral height)
    surfaceData <- imageSurfaceGetPixels icon :: IO (SurfaceData Int Word32)
    forM_ (zip thisIcon [1..]) $ \(e, i) -> writeArray surfaceData i $ premultiply $ fromIntegral e
    
    surfaceMarkDirty icon
  
    moreIcons <- readIcons rest
    return $ (fromIntegral $ max width height, icon):moreIcons

readIcons _ = return []

premultiply :: Word32 -> Word32
premultiply c = a .|. r .|. g .|. b
  where
    amask = 0xFF000000
    rmask = 0x00FF0000
    gmask = 0x0000FF00
    bmask = 0x000000FF
    
    a = c .&. amask
    pm mask = (((c .&. mask) * (a `shiftR` 24)) `div` 0xFF) .&. mask
    
    r = pm rmask
    g = pm gmask
    b = pm bmask

showWindow :: Xlib.Display -> Atoms -> Window -> IO Bool
showWindow disp atoms window = do
  states <- liftM (map fromIntegral . fromMaybe []) $ XExtras.getWindowProperty32 disp (atom_NET_WM_STATE atoms) window
  transientForHint <- XExtras.getTransientForHint disp window
  windowType <- liftM (fromMaybe (atom_NET_WM_WINDOW_TYPE_NORMAL atoms) . fmap fromIntegral . join . fmap listToMaybe) $ XExtras.getWindowProperty32 disp (atom_NET_WM_STATE atoms) window
  
  return $ not $ or [ elem (atom_NET_WM_STATE_SKIP_TASKBAR atoms) states 
                    , transientForHint /= Nothing
                    , elem windowType $ map ($ atoms) [ atom_NET_WM_WINDOW_TYPE_DOCK 
                                                      , atom_NET_WM_WINDOW_TYPE_DESKTOP 
                                                      , atom_NET_WM_WINDOW_TYPE_TOOLBAR 
                                                      , atom_NET_WM_WINDOW_TYPE_MENU 
                                                      , atom_NET_WM_WINDOW_TYPE_SPLASH
                                                      ]
                    ]


getWindowList :: Xlib.Display -> Atoms -> [Window] -> IO [Window]
getWindowList disp atoms windows = do
  newWindows <- liftM (map fromIntegral . join . maybeToList) $ XExtras.getWindowProperty32 disp (atom_NET_CLIENT_LIST atoms) $ Xlib.defaultRootWindow disp
  return $ (filter (flip elem newWindows) windows) ++ (filter (not . flip elem windows) newWindows)


taskbar :: TaskbarConfig -> Widget
taskbar config = do
  Widget $ Taskbar config