path: root/XMonad/Util/XUtils.hs

-----------------------------------------------------------------------------
-- |
-- Module      :  XMonad.Util.XUtils
-- Copyright   :  (c) 2007 Andrea Rossato
--                    2010 Alejandro Serrano
-- License     :  BSD-style (see xmonad/LICENSE)
--
-- Maintainer  :  andrea.rossato@unibz.it
-- Stability   :  unstable
-- Portability :  unportable
--
-- A module for painting on the screen
--
-----------------------------------------------------------------------------

module XMonad.Util.XUtils
    ( -- * Usage:
      -- $usage
      averagePixels
    , createNewWindow
    , showWindow
    , showWindows
    , hideWindow
    , hideWindows
    , deleteWindow
    , deleteWindows
    , paintWindow
    , paintAndWrite
    , paintTextAndIcons
    , stringToPixel
    , fi
    ) where

import Data.Maybe
import XMonad
import XMonad.Util.Font
import XMonad.Util.Image
import Control.Monad

-- $usage
-- See "XMonad.Layout.Tabbed" or "XMonad.Layout.DragPane" or
-- "XMonad.Layout.Decoration" for usage examples

-- | Compute the weighted average the colors of two given Pixel values.
averagePixels :: Pixel -> Pixel -> Double -> X Pixel
averagePixels p1 p2 f =
    do d <- asks display
       let cm = defaultColormap d (defaultScreen d)
       [Color _ r1 g1 b1 _,Color _ r2 g2 b2 _] <- io $ queryColors d cm [Color p1 0 0 0 0,Color p2 0 0 0 0]
       let mn x1 x2 = round (fromIntegral x1 * f + fromIntegral x2 * (1-f))
       Color p _ _ _ _ <- io $ allocColor d cm (Color 0 (mn r1 r2) (mn g1 g2) (mn b1 b2) 0)
       return p

-- | Create a simple window given a rectangle. If Nothing is given
-- only the exposureMask will be set, otherwise the Just value.
-- Use 'showWindow' to map and hideWindow to unmap.
createNewWindow :: Rectangle -> Maybe EventMask -> String -> Bool -> X Window
createNewWindow (Rectangle x y w h) m col o = do
  d   <- asks display
  rw  <- asks theRoot
  c   <- stringToPixel d col
  win <- io $ mkWindow d (defaultScreenOfDisplay d) rw x y w h c o
  case m of
    Just em -> io $ selectInput d win em
    Nothing -> io $ selectInput d win exposureMask
  -- @@@ ugly hack to prevent compositing
  whenX (return $ isJust m) $ flip catchX (return ()) $ do
    wINDOW_TYPE <- getAtom "_NET_WM_WINDOW_TYPE"
    dESKTOP <- getAtom "_NET_WM_WINDOW_TYPE_DESKTOP"
    io $ changeProperty32 d win wINDOW_TYPE aTOM propModeReplace [fi dESKTOP]
  return win

-- | Map a window
showWindow :: Window -> X ()
showWindow w = do
  d <- asks display
  io $ mapWindow d w

-- | the list version
showWindows :: [Window] -> X ()
showWindows = mapM_ showWindow

-- | unmap a window
hideWindow :: Window -> X ()
hideWindow w = do
  d <- asks display
  io $ unmapWindow d w

-- | the list version
hideWindows :: [Window] -> X ()
hideWindows = mapM_ hideWindow

-- | destroy a window
deleteWindow :: Window -> X ()
deleteWindow w = do
  d <- asks display
  io $ destroyWindow d w

-- | the list version
deleteWindows :: [Window] -> X ()
deleteWindows = mapM_ deleteWindow

-- | Fill a window with a rectangle and a border
paintWindow :: Window     -- ^ The window where to draw
            -> Dimension  -- ^ Window width
            -> Dimension  -- ^ Window height
            -> Dimension  -- ^ Border width
            -> String     -- ^ Window background color
            -> String     -- ^ Border color
            -> X ()
paintWindow w wh ht bw c bc =
    paintWindow' w (Rectangle 0 0 wh ht) bw c bc Nothing Nothing

-- | Fill a window with a rectangle and a border, and write
-- | a number of strings to given positions
paintAndWrite :: Window     -- ^ The window where to draw
              -> XMonadFont -- ^ XMonad Font for drawing
              -> Dimension  -- ^ Window width
              -> Dimension  -- ^ Window height
              -> Dimension  -- ^ Border width
              -> String     -- ^ Window background color
              -> String     -- ^ Border color
              -> String     -- ^ String color
              -> String     -- ^ String background color
              -> [Align]    -- ^ String 'Align'ments
              -> [String]   -- ^ Strings to be printed
              -> X ()
paintAndWrite w fs wh ht bw bc borc ffc fbc als strs = do
    d <- asks display
    strPositions <- forM (zip als strs) $ \(al, str) ->
        stringPosition d fs (Rectangle 0 0 wh ht) al str
    let ms = Just (fs,ffc,fbc, zip strs strPositions)
    paintWindow' w (Rectangle 0 0 wh ht) bw bc borc ms Nothing

-- | Fill a window with a rectangle and a border, and write
-- | a number of strings and a number of icons to given positions
paintTextAndIcons :: Window      -- ^ The window where to draw
                  -> XMonadFont  -- ^ XMonad Font for drawing
                  -> Dimension   -- ^ Window width
                  -> Dimension   -- ^ Window height
                  -> Dimension   -- ^ Border width
                  -> String      -- ^ Window background color
                  -> String      -- ^ Border color
                  -> String      -- ^ String color
                  -> String      -- ^ String background color
                  -> [Align]     -- ^ String 'Align'ments
                  -> [String]    -- ^ Strings to be printed
                  -> [Placement] -- ^ Icon 'Placements'
                  -> [[[Bool]]]  -- ^ Icons to be printed
                  -> X ()
paintTextAndIcons w fs wh ht bw bc borc ffc fbc als strs i_als icons = do
    d <- asks display
    strPositions <- forM (zip als strs) $ \(al, str) ->
        stringPosition d fs (Rectangle 0 0 wh ht) al str
    let iconPositions = map ( \(al, icon) -> iconPosition (Rectangle 0 0 wh ht) al icon ) (zip i_als icons)
        ms = Just (fs,ffc,fbc, zip strs strPositions)
        is = Just (ffc, fbc, zip iconPositions icons)
    paintWindow' w (Rectangle 0 0 wh ht) bw bc borc ms is

-- This stuff is not exported

-- | Paints a titlebar with some strings and icons
-- drawn inside it.
-- Not exported.
paintWindow' :: Window -> Rectangle -> Dimension -> String -> String
                -> Maybe (XMonadFont,String,String,[(String, (Position, Position))])
                -> Maybe (String, String, [((Position, Position), [[Bool]])]) -> X ()
paintWindow' win (Rectangle _ _ wh ht) bw color b_color strStuff iconStuff = do
  d  <- asks display
  p  <- io $ createPixmap d win wh ht (defaultDepthOfScreen $ defaultScreenOfDisplay d)
  gc <- io $ createGC d p
  -- draw
  io $ setGraphicsExposures d gc False
  [color',b_color'] <- mapM (stringToPixel d) [color,b_color]
  -- we start with the border
  io $ setForeground d gc b_color'
  io $ fillRectangle d p gc 0 0 wh ht
  -- and now again
  io $ setForeground d gc color'
  io $ fillRectangle d p gc (fi bw) (fi bw) (wh - (bw * 2)) (ht - (bw * 2))
  -- paint strings
  when (isJust strStuff) $ do
    let (xmf,fc,bc,strAndPos) = fromJust strStuff
    forM_ strAndPos $ \(s, (x, y)) ->
        printStringXMF d p xmf gc fc bc x y s
  -- paint icons
  when (isJust iconStuff) $ do
    let (fc, bc, iconAndPos) = fromJust iconStuff
    forM_ iconAndPos $ \((x, y), icon) ->
      drawIcon d p gc fc bc x y icon
  -- copy the pixmap over the window
  io $ copyArea      d p win gc 0 0 wh ht 0 0
  -- free the pixmap and GC
  io $ freePixmap    d p
  io $ freeGC        d gc

-- | Creates a window with the possibility of setting some attributes.
-- Not exported.
mkWindow :: Display -> Screen -> Window -> Position
         -> Position -> Dimension -> Dimension -> Pixel -> Bool -> IO Window
mkWindow d s rw x y w h p o = do
  let visual = defaultVisualOfScreen s
      attrmask = cWOverrideRedirect .|. cWBackPixel .|. cWBorderPixel
  allocaSetWindowAttributes $
         \attributes -> do
           set_override_redirect attributes o
           set_border_pixel      attributes p
           set_background_pixel  attributes p
           createWindow d rw x y w h 0 (defaultDepthOfScreen s)
                        inputOutput visual attrmask attributes