phi/lib/Phi/X11.hs

{-# LANGUAGE GeneralizedNewtypeDeriving #-}

module Phi.X11 ( XConfig(..)
               , defaultXConfig
               , initPhi
               ) where

import Graphics.X11.Xlib
import Graphics.X11.Xlib.Extras
import Graphics.X11.Xinerama

import Control.Monad
import Data.Maybe
import Data.Bits

import Control.Monad.State
import Control.Monad.Reader
import Control.Monad.Trans

import qualified Phi.Panel as Panel

data XConfig = XConfig { phiXScreenInfo :: Display -> IO [Rectangle]
                       }

data PhiState = PhiState { phiDisplay    :: Display
                         , phiRootPixmap :: Pixmap
                         , phiPanels     :: [PanelState]
                         }

data PanelState = PanelState { panelWindow     :: Window
                             , panelGC         :: GC
                             , panelArea       :: Rectangle
                             , panelScreenArea :: Rectangle
                             }

data PhiConfig = PhiConfig { phiPanelConfig :: Panel.PanelConfig
                           , phiXConfig     :: XConfig
                           }

newtype PhiReader a = PhiReader (ReaderT PhiConfig IO a)
                    deriving (Monad, MonadReader PhiConfig, MonadIO)

runPhiReader :: PhiConfig -> PhiReader a -> IO a
runPhiReader config (PhiReader a) = runReaderT a config

newtype Phi a = Phi (StateT PhiState PhiReader a)
              deriving (Monad, MonadState PhiState, MonadReader PhiConfig, MonadIO)

runPhi :: PhiConfig -> PhiState -> Phi a -> IO (a, PhiState)
runPhi config st (Phi a) = runPhiReader config $ runStateT a st

liftIOContToPhi :: ((a -> IO (b, PhiState)) -> IO (b, PhiState)) -> (a -> Phi b) -> Phi b
liftIOContToPhi f c = do
  config <- ask
  state <- get
  (a, state') <- liftIO $ f $ \x -> runPhi config state $ c x
  put state'
  return a


defaultXConfig = XConfig { phiXScreenInfo = getScreenInfo
                         }

initPhi :: XConfig -> Panel.PanelConfig -> IO ()
initPhi xconfig config = do
  disp <- openDisplay []
  selectInput disp (defaultRootWindow disp) $ propertyChangeMask.|.structureNotifyMask
  
  runPhi PhiConfig { phiXConfig = xconfig, phiPanelConfig = config } PhiState { phiDisplay = disp, phiRootPixmap = 0, phiPanels = [] } $ do
    updateRootPixmap
    
    screens <- liftIO $ phiXScreenInfo xconfig disp
    panels <- mapM createPanel screens
    forM_ panels $ \panel -> do
      setPanelProperties panel
      liftIO $ mapWindow disp (panelWindow panel)
    
    modify $ \state -> state { phiPanels = panels }
    
    liftIOContToPhi allocaXEvent $ \xevent -> do
      forever $ do
        liftIO $ nextEvent disp xevent
        event <- liftIO $ getEvent xevent
        
        case event of
          ExposeEvent {} -> updatePanels
          PropertyEvent {} -> handlePropertyUpdate event
          _ -> return ()
  return ()


updatePanels :: Phi ()
updatePanels = do
  disp <- gets phiDisplay
  rootPixmap <- gets phiRootPixmap
  panels <- gets phiPanels
  forM_ panels $ \panel -> liftIO $ withRectangle (panelArea panel) (copyArea disp rootPixmap (panelWindow panel) (panelGC panel)) 0 0


handlePropertyUpdate :: Event -> Phi ()
handlePropertyUpdate PropertyEvent { ev_atom = atom } = do
  disp <- gets phiDisplay
  panels <- gets phiPanels
  atom_XROOTPMAP_ID <- liftIO $ internAtom disp "_XROOTPMAP_ID" False
  atom_XROOTMAP_ID <- liftIO $ internAtom disp "_XROOTMAP_ID" False

  when (atom == atom_XROOTPMAP_ID || atom == atom_XROOTMAP_ID) $ do
    updateRootPixmap
    updatePanels
  

updateRootPixmap :: Phi ()
updateRootPixmap = do
  disp <- gets phiDisplay
  let screen = defaultScreen disp
      rootwin = defaultRootWindow disp
  atom_XROOTPMAP_ID <- liftIO $ internAtom disp "_XROOTPMAP_ID" False
  atom_XROOTMAP_ID <- liftIO $ internAtom disp "_XROOTMAP_ID" False
  pixmap <- liftM (fromMaybe 0 . listToMaybe . join . catMaybes) $ forM [atom_XROOTPMAP_ID, atom_XROOTMAP_ID] $ \atom -> liftIO $ rawGetWindowProperty 32 disp atom rootwin
  modify $ \state -> state { phiRootPixmap = pixmap }


createPanel :: Rectangle -> Phi PanelState
createPanel screen = do
  config <- asks phiPanelConfig
  let rect = panelBounds config screen
  disp <- gets phiDisplay
  win <- createPanelWindow rect
  gc <- liftIO $ createGC disp win
  return PanelState { panelWindow = win, panelGC = gc, panelArea = rect, panelScreenArea = screen }


createPanelWindow :: Rectangle -> Phi Window
createPanelWindow rect = do
  disp <- gets phiDisplay
  let screen = defaultScreen disp
      depth = defaultDepth disp screen
      visual = defaultVisual disp screen
      colormap = defaultColormap disp screen
      rootwin = defaultRootWindow disp
      mask = cWEventMask.|.cWColormap.|.cWBackPixel.|.cWBorderPixel

  liftIO $ allocaSetWindowAttributes $ \attr -> do
    set_colormap attr colormap
    set_background_pixel attr 0
    set_border_pixel attr 0
    set_event_mask attr exposureMask
    withRectangle rect (createWindow disp rootwin) 0 depth inputOutput visual mask attr


setPanelProperties :: PanelState -> Phi ()
setPanelProperties panel = do
  disp <- gets phiDisplay
  liftIO $ do
    atom_NET_WM_WINDOW_TYPE <- internAtom disp "_NET_WM_WINDOW_TYPE" False
    atom_NET_WM_WINDOW_TYPE_DOCK <- internAtom disp "_NET_WM_WINDOW_TYPE_DOCK" False
    
    atom_NET_WM_DESKTOP <- internAtom disp "_NET_WM_DESKTOP" False
    
    atom_NET_WM_STATE <- internAtom disp "_NET_WM_STATE" False
    atom_NET_WM_STATE_SKIP_PAGER <- internAtom disp "_NET_WM_STATE_SKIP_PAGER" False
    atom_NET_WM_STATE_SKIP_TASKBAR <- internAtom disp "_NET_WM_STATE_SKIP_TASKBAR" False
    atom_NET_WM_STATE_STICKY <- internAtom disp "_NET_WM_STATE_STICKY" False
    atom_NET_WM_STATE_BELOW <- internAtom disp "_NET_WM_STATE_BELOW" False
    
    atom_MOTIF_WM_HINTS <- internAtom disp "_MOTIF_WM_HINTS" False
    
    storeName disp (panelWindow panel) "Phi"
    changeProperty32 disp (panelWindow panel) atom_NET_WM_WINDOW_TYPE aTOM propModeReplace [fromIntegral atom_NET_WM_WINDOW_TYPE_DOCK]
    changeProperty32 disp (panelWindow panel) atom_NET_WM_DESKTOP cARDINAL propModeReplace [0xFFFFFFFF]
    changeProperty32 disp (panelWindow panel) atom_NET_WM_STATE aTOM propModeReplace [ fromIntegral atom_NET_WM_STATE_SKIP_PAGER
                                                                                     , fromIntegral atom_NET_WM_STATE_SKIP_TASKBAR
                                                                                     , fromIntegral atom_NET_WM_STATE_STICKY
                                                                                     , fromIntegral atom_NET_WM_STATE_BELOW]
    setWMHints disp (panelWindow panel) WMHints { wmh_flags = fromIntegral inputHintBit
                                                , wmh_input = False
                                                , wmh_initial_state = 0
                                                , wmh_icon_pixmap = 0
                                                , wmh_icon_window = 0
                                                , wmh_icon_x = 0
                                                , wmh_icon_y = 0
                                                , wmh_icon_mask = 0
                                                , wmh_window_group = 0
                                                }
    changeProperty32 disp (panelWindow panel) atom_MOTIF_WM_HINTS atom_MOTIF_WM_HINTS propModeReplace [ 2, 0, 0, 0, 0 ]
  setStruts panel


setStruts :: PanelState -> Phi ()
setStruts panel = do
  disp <- gets phiDisplay
  config <- asks phiPanelConfig
  let rootwin = defaultRootWindow disp
      position = Panel.panelPosition config
      area = panelArea panel
  (_, _, _, _, rootHeight, _, _) <- liftIO $ getGeometry disp rootwin
  
  let struts = [makeStruts i | i <- [0..11]]
          where
            makeTopStruts 2 = (fromIntegral $ rect_y area) + (fromIntegral $ rect_height area)
            makeTopStruts 8 = (fromIntegral $ rect_x area)
            makeTopStruts 9 = (fromIntegral $ rect_x area) + (fromIntegral $ rect_width area) - 1
            makeTopStruts _ = 0
            
            makeBottomStruts 3 = (fromIntegral rootHeight) - (fromIntegral $ rect_y area)
            makeBottomStruts 10 = (fromIntegral $ rect_x area)
            makeBottomStruts 11 = (fromIntegral $ rect_x area) + (fromIntegral $ rect_width area) - 1
            makeBottomStruts _ = 0
            
            makeStruts = case position of
              Panel.Top -> makeTopStruts
              Panel.Bottom -> makeBottomStruts
  
  liftIO $ do
    atom_NET_WM_STRUT <- internAtom disp "_NET_WM_STRUT" False
    atom_NET_WM_STRUT_PARTIAL <- internAtom disp "_NET_WM_STRUT_PARTIAL" False
    
    changeProperty32 disp (panelWindow panel) atom_NET_WM_STRUT cARDINAL propModeReplace $ take 4 struts
    changeProperty32 disp (panelWindow panel) atom_NET_WM_STRUT_PARTIAL cARDINAL propModeReplace struts


panelBounds :: Panel.PanelConfig -> Rectangle -> Rectangle
panelBounds config screenBounds = case Panel.panelPosition config of
  Panel.Top -> screenBounds { rect_height = fromIntegral $ Panel.panelSize config }
  Panel.Bottom -> screenBounds { rect_height = fromIntegral $ Panel.panelSize config,
                                        rect_y = (rect_y screenBounds) + (fromIntegral $ rect_height screenBounds) - (fromIntegral $ Panel.panelSize config) }

withRectangle :: Rectangle -> (Position -> Position -> Dimension -> Dimension -> a) -> a
withRectangle r = withDimension r . withPosition r

withPosition :: Rectangle -> (Position -> Position -> a) -> a
withPosition r f = f (rect_x r) (rect_y r)

withDimension :: Rectangle -> (Dimension -> Dimension -> a) -> a
withDimension r f = f (rect_width r) (rect_height r)