phi/lib/Phi/Widgets/Systray.hs

{-# LANGUAGE TypeFamilies, DeriveDataTypeable #-}

module Phi.Widgets.Systray ( systray
                           ) where

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

import Data.Bits
import Data.IORef
import Data.Maybe
import Data.Typeable
import qualified Data.Map as M

import Foreign.C.Types

import Graphics.Rendering.Cairo
import Graphics.Rendering.Cairo.Types

import Graphics.X11.Xlib hiding (Display)
import qualified Graphics.X11.Xlib as Xlib
import Graphics.X11.Xlib.Extras

import Phi.Bindings.Util

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


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

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

instance Show (IORef a) where
  show _ = "IORef <?>"


data SystrayIconState = SystrayIconState Window Window deriving Show

data SystrayState = SystrayState Phi Rectangle Int (IORef Int) [SystrayIconState] deriving Show

data Systray = Systray deriving Show

data SystrayMessage = AddIcon Window Window | RemoveIcon Window | RenderIcon Window Window Int Int Int Int Bool
                      deriving (Show, Typeable)


instance WidgetClass Systray where
  type WidgetData Systray = SystrayState
  
  initWidget (Systray) phi dispvar = do
    forkIO $ systrayRunner phi dispvar
    
    lastReset <- newIORef 0
    return $ SystrayState phi (head . getScreens $ dispvar) 0 lastReset []
  
  minSize _ (SystrayState _ systrayScreen _ _ icons) height screen = case True of 
    _ | screen == systrayScreen -> (length icons)*height
      | otherwise -> 0

  weight _ = 0
  
  render Systray (SystrayState phi systrayScreen reset lastResetRef icons) w h screen = case True of 
    _ | screen == systrayScreen -> do
      lastReset <- liftIO $ readIORef lastResetRef
      liftIO $ writeIORef lastResetRef reset
      Matrix _ _ _ _ dx dy <- getMatrix
      forM_ (zip [0..] icons) $ \(i, SystrayIconState midParent window) -> do
        let x = round dx + i*h 
            y = round dy
        sendMessage phi $ RenderIcon midParent window x y h h (lastReset /= reset)
        
      | otherwise -> return ()
  
  handleMessage _ priv@(SystrayState phi screen reset lastReset icons) m = case (fromMessage m) of
    Just (AddIcon midParent window) -> SystrayState phi screen reset lastReset ((SystrayIconState midParent window):icons)
    Just (RemoveIcon window) -> SystrayState phi screen reset lastReset $ filter (\(SystrayIconState _ stateWindow) -> stateWindow /= window) icons
    _ -> case (fromMessage m) of
      Just ResetBackground -> SystrayState phi screen (reset+1) lastReset icons
      _ ->  priv


systrayRunner :: Phi -> Display -> IO ()
systrayRunner phi dispvar = do
  let atoms = getAtoms dispvar
  initSuccess <- withDisplay dispvar $ flip initSystray atoms
  
  case initSuccess of
    Just xembedWindow -> flip evalStateT M.empty $ forever $ do
      m <- receiveMessage phi
      case (fromMessage m) of
        Just event ->
          handleEvent event phi dispvar xembedWindow
        _ ->
          case (fromMessage m) of
            Just (RenderIcon midParent window x y w h reset) -> do
              errorWindowRef <- liftIO $ newIORef []
              
              withDisplay dispvar $ \disp -> do
                liftIO $ do
                  sync disp False
                  setErrorHandler $ \disp eventptr -> do
                    event <- getErrorEvent eventptr
                    when (ev_error_code event == fromIntegral badWindow) $ do
                      errorWindows <- readIORef errorWindowRef
                      writeIORef errorWindowRef (ev_resourceid event:errorWindows)

                (_, x', y', w', h', _, _) <- liftIO $ getGeometry disp midParent
                let resize = (fromIntegral x) /= x' || (fromIntegral y) /= y' || (fromIntegral w) /= w' || (fromIntegral h) /= h'
                
                when resize $ liftIO $ do
                  moveResizeWindow disp midParent (fromIntegral x) (fromIntegral y) (fromIntegral w) (fromIntegral h)
                  resizeWindow disp window (fromIntegral w) (fromIntegral h)
                  liftIO $ sync disp False
                
                when (resize || reset) $ liftIO $ do
                  clearArea disp midParent 0 0 (fromIntegral w) (fromIntegral h) True
                  liftIO $ sync disp False
                  clearArea disp window 0 0 (fromIntegral w) (fromIntegral h) True
                  liftIO $ sync disp False
                
                liftIO $ xSetErrorHandler
                
                errorWindows <- liftIO $ readIORef errorWindowRef
                mapM_ (removeIcon phi disp) errorWindows
            _ ->
              return ()
    Nothing ->
      return ()


initSystray :: Xlib.Display -> Atoms -> IO (Maybe Window)
initSystray disp atoms = do
  currentSystrayWin <- xGetSelectionOwner disp $ atom_NET_SYSTEM_TRAY_SCREEN atoms
  
  if currentSystrayWin /= 0 then do
    pid <- liftM (fromMaybe "" . fmap (\pid -> " (pid" ++ show (fromIntegral pid :: CUShort) ++ ")") . join . fmap listToMaybe) $
           getWindowProperty16 disp (atom_NET_WM_PID atoms) currentSystrayWin
    
    putStrLn $ "Phi: another systray is running." ++ pid
    
    return Nothing
    else do
    xembedWin <- createSimpleWindow disp (defaultRootWindow disp) (-1) (-1) 1 1 0 0 0
    
    -- orient horizontally
    changeProperty32 disp xembedWin (atom_NET_SYSTEM_TRAY_ORIENTATION atoms) cARDINAL propModeReplace [0]
    
    -- set visual
    let rootwin = defaultRootWindow disp
        screen = defaultScreen disp
        visual = defaultVisual disp screen
        visualID = visualIDFromVisual visual
    changeProperty32 disp xembedWin (atom_NET_SYSTEM_TRAY_VISUAL atoms) vISUALID propModeReplace [fromIntegral visualID]
    
    xSetSelectionOwner disp (atom_NET_SYSTEM_TRAY_SCREEN atoms) xembedWin currentTime
    systrayWin <- xGetSelectionOwner disp $ atom_NET_SYSTEM_TRAY_SCREEN atoms
    if systrayWin /= xembedWin then do
      destroyWindow disp xembedWin
      putStrLn $ "Phi: can't initialize systray."
      return Nothing
      
      else do
      allocaXEvent $ \event -> do
        putClientMessage event rootwin (atomMANAGER atoms) [fromIntegral currentTime, fromIntegral (atom_NET_SYSTEM_TRAY_SCREEN atoms), fromIntegral xembedWin, 0, 0]
        sendEvent disp rootwin False structureNotifyMask event
      
      return $ Just xembedWin


sYSTEM_TRAY_REQUEST_DOCK :: CInt
sYSTEM_TRAY_REQUEST_DOCK = 0

sYSTEM_TRAY_BEGIN_MESSAGE :: CInt
sYSTEM_TRAY_BEGIN_MESSAGE = 1

sYSTEM_TRAY_CANCEL_MESSAGE :: CInt
sYSTEM_TRAY_CANCEL_MESSAGE = 2

xEMBED_EMBEDDED_NOTIFY :: CInt
xEMBED_EMBEDDED_NOTIFY = 0

handleEvent :: Event -> Phi -> Display -> Window -> StateT (M.Map Window Window) IO ()
handleEvent message@ClientMessageEvent { ev_message_type = message_type, ev_data = messageData, ev_window = window } phi dispvar xembedWindow = do
  let atoms = getAtoms dispvar
      screenWindows = getScreenWindows dispvar
  when (window == xembedWindow && message_type == atom_NET_SYSTEM_TRAY_OPCODE atoms) $ do
    case messageData of
      _:opcode:iconID:_ -> do
        case True of
          _ | opcode == sYSTEM_TRAY_REQUEST_DOCK -> do
            when (iconID /= 0) $ withDisplay dispvar $ \disp -> addIcon phi disp (getAtoms dispvar) (snd . head $ screenWindows) $ fromIntegral iconID
          
            | opcode == sYSTEM_TRAY_BEGIN_MESSAGE || opcode == sYSTEM_TRAY_CANCEL_MESSAGE ->
            return ()
            
            | otherwise -> do
            liftIO $ putStrLn "Phi: unknown tray message"
            return ()
        
          
      _ ->
        return ()

handleEvent message@UnmapEvent { ev_window = window } phi dispvar xembedWindow =
  withDisplay dispvar $ flip (removeIcon phi) window

handleEvent message@DestroyWindowEvent { ev_window = window } phi dispvar xembedWindow =
  withDisplay dispvar $ flip (removeIcon phi) window

handleEvent _ _ _ _ = return ()


addIcon :: Phi -> Xlib.Display -> Atoms -> Window -> Window -> StateT (M.Map Window Window) IO ()
addIcon phi disp atoms panelWindow window = do
  liftIO $ selectInput disp window $ structureNotifyMask .|. propertyChangeMask
  
  errorRef <- liftIO $ newIORef False
  midParent <- liftIO $ createSimpleWindow disp panelWindow (-16) (-16) 16 16 0 0 0
  
  liftIO $ do
    setWindowBackgroundPixmap disp midParent 1 -- ParentRelative
    
    sync disp False
    setErrorHandler $ \disp eventptr -> do
      event <- getErrorEvent eventptr
      when (ev_error_code event == fromIntegral badWindow && ev_resourceid event == window) $
        writeIORef errorRef True
    
    reparentWindow disp window midParent 0 0
    sync disp False
    
    mapRaised disp midParent
    mapWindow disp window
    sync disp False
    
    allocaXEvent $ \event -> do
      putClientMessage event window (atom_XEMBED atoms) [fromIntegral currentTime, fromIntegral xEMBED_EMBEDDED_NOTIFY, 0, fromIntegral midParent, 0]
      sendEvent disp window False 0xFFFFFF event
    
    sync disp False
    xSetErrorHandler
  
  error <- liftIO $ readIORef errorRef
  case error of
    False -> do
      sendMessage phi $ AddIcon midParent window
      sendMessage phi Repaint
      modify $ M.insert window midParent
    True ->
      liftIO $ destroyWindow disp midParent


removeIcon :: Phi -> Xlib.Display -> Window -> StateT (M.Map Window Window) IO ()
removeIcon phi disp window = do
  mmidParent <- gets $ M.lookup window
  case mmidParent of
    Just midParent -> do
      sendMessage phi $ RemoveIcon window
      sendMessage phi Repaint
      liftIO $ do
        reparentWindow disp window (defaultRootWindow disp) 0 0
        destroyWindow disp midParent
    _ ->
      return ()


systray :: Widget
systray = Widget $ Systray