Merge for pull request #53

1 files changed, 167 insertions, 0 deletions

diff --git a/src/Window.hs b/src/Window.hs
new file mode 100644
index 0000000..0ffa139
--- /dev/null
+++ b/src/Window.hs
@@ -0,0 +1,167 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Window
+-- Copyright   :  (c) 2011-12 Jose A. Ortega Ruiz
+--             :  (c) 2012 Jochen Keil
+-- License     :  BSD-style (see LICENSE)
+--
+-- Maintainer  :  Jose A. Ortega Ruiz <jao@gnu.org>
+-- Stability   :  unstable
+-- Portability :  unportable
+--
+-- Window manipulation functions
+--
+-----------------------------------------------------------------------------
+
+module Window where
+
+import Prelude hiding (catch)
+import Control.Monad (when)
+import Graphics.X11.Xlib hiding (textExtents, textWidth)
+import Graphics.X11.Xlib.Extras
+import Graphics.X11.Xinerama
+
+import Data.Maybe(fromMaybe)
+import System.Posix.Process (getProcessID)
+
+import Config
+import XUtil
+
+-- $window
+
+-- | The function to create the initial window
+createWin :: Display -> XFont -> Config -> IO (Rectangle,Window)
+createWin d fs c = do
+  let dflt = defaultScreen d
+  srs     <- getScreenInfo d
+  rootw   <- rootWindow d dflt
+  (as,ds) <- textExtents fs "0"
+  let ht    = as + ds + 4
+      (r,o) = setPosition (position c) srs (fi ht)
+  win <- newWindow  d (defaultScreenOfDisplay d) rootw r o
+  setProperties r c d win srs
+  when (lowerOnStart c) (lowerWindow d win)
+  mapWindow         d win
+  return (r,win)
+
+-- | Updates the size and position of the window
+repositionWin :: Display -> Window -> XFont -> Config -> IO Rectangle
+repositionWin d win fs c = do
+  srs     <- getScreenInfo d
+  (as,ds) <- textExtents fs "0"
+  let ht    = as + ds + 4
+      (r,_) = setPosition (position c) srs (fi ht)
+  moveResizeWindow d win (rect_x r) (rect_y r) (rect_width r) (rect_height r)
+  setProperties r c d win srs
+  return r
+
+setPosition :: XPosition -> [Rectangle] -> Dimension -> (Rectangle,Bool)
+setPosition p rs ht =
+  case p' of
+    Top -> (Rectangle rx ry rw h, True)
+    TopW a i -> (Rectangle (ax a i) ry (nw i) h, True)
+    TopSize a i ch -> (Rectangle (ax a i) ry (nw i) (mh ch), True)
+    Bottom -> (Rectangle rx ny rw h, True)
+    BottomW a i -> (Rectangle (ax a i) ny (nw i) h, True)
+    BottomSize a i ch  -> (Rectangle (ax a i) (ny' ch) (nw i) (mh ch), True)
+    Static cx cy cw ch -> (Rectangle (fi cx) (fi cy) (fi cw) (fi ch), True)
+    OnScreen _ p'' -> setPosition p'' [scr] ht
+  where
+    (scr@(Rectangle rx ry rw rh), p') =
+      case p of OnScreen i x -> (fromMaybe (head rs) $ safeIndex i rs, x)
+                _ -> (head rs, p)
+    ny       = ry + fi (rh - ht)
+    center i = rx + fi (div (remwid i) 2)
+    right  i = rx + fi (remwid i)
+    remwid i = rw - pw (fi i)
+    ax L     = const rx
+    ax R     = right
+    ax C     = center
+    pw i     = rw * min 100 i `div` 100
+    nw       = fi . pw . fi
+    h        = fi ht
+    mh h'    = max (fi h') h
+    ny' h'   = ry + fi (rh - mh h')
+    safeIndex i = lookup i . zip [0..]
+
+setProperties :: Rectangle -> Config -> Display -> Window -> [Rectangle] -> IO ()
+setProperties r c d w srs = do
+  a1 <- internAtom d "_NET_WM_STRUT_PARTIAL"    False
+  c1 <- internAtom d "CARDINAL"                 False
+  a2 <- internAtom d "_NET_WM_WINDOW_TYPE"      False
+  c2 <- internAtom d "ATOM"                     False
+  v  <- internAtom d "_NET_WM_WINDOW_TYPE_DOCK" False
+  p  <- internAtom d "_NET_WM_PID"              False
+
+  setTextProperty d w "xmobar" wM_CLASS
+  setTextProperty d w "xmobar" wM_NAME
+
+  changeProperty32 d w a1 c1 propModeReplace $ map fi $
+    getStrutValues r (position c) (getRootWindowHeight srs)
+  changeProperty32 d w a2 c2 propModeReplace [fromIntegral v]
+
+  getProcessID >>= changeProperty32 d w p c1 propModeReplace . return . fromIntegral
+
+getRootWindowHeight :: [Rectangle] -> Int
+getRootWindowHeight srs = maximum (map getMaxScreenYCoord srs)
+  where
+    getMaxScreenYCoord sr = fi (rect_y sr) + fi (rect_height sr)
+
+getStrutValues :: Rectangle -> XPosition -> Int -> [Int]
+getStrutValues r@(Rectangle x y w h) p rwh =
+    case p of
+    OnScreen _ p'   -> getStrutValues r p' rwh
+    Top             -> [0, 0, st,  0, 0, 0, 0, 0, nx, nw,  0,  0]
+    TopW    _ _     -> [0, 0, st,  0, 0, 0, 0, 0, nx, nw,  0,  0]
+    TopSize      {} -> [0, 0, st,  0, 0, 0, 0, 0, nx, nw,  0,  0]
+    Bottom          -> [0, 0,  0, sb, 0, 0, 0, 0,  0,  0, nx, nw]
+    BottomW _ _     -> [0, 0,  0, sb, 0, 0, 0, 0,  0,  0, nx, nw]
+    BottomSize   {} -> [0, 0,  0, sb, 0, 0, 0, 0,  0,  0, nx, nw]
+    Static       {} -> getStaticStrutValues p rwh
+    where st = fi y + fi h
+          sb = rwh - fi y
+          nx = fi x
+          nw = fi (x + fi w - 1)
+
+-- get some reaonable strut values for static placement.
+getStaticStrutValues :: XPosition -> Int -> [Int]
+getStaticStrutValues (Static cx cy cw ch) rwh
+    -- if the yPos is in the top half of the screen, then assume a Top
+    -- placement, otherwise, it's a Bottom placement
+    | cy < (rwh `div` 2) = [0, 0, st,  0, 0, 0, 0, 0, xs, xe,  0,  0]
+    | otherwise          = [0, 0,  0, sb, 0, 0, 0, 0,  0,  0, xs, xe]
+    where st = cy + ch
+          sb = rwh - cy
+          xs = cx -- a simple calculation for horizontal (x) placement
+          xe = xs + cw
+getStaticStrutValues _ _ = [0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0]
+
+drawBorder :: Border -> Display -> Drawable -> GC -> Pixel
+              -> Dimension -> Dimension -> IO ()
+drawBorder b d p gc c wi ht =  case b of
+  NoBorder -> return ()
+  TopB       -> drawBorder (TopBM 0) d p gc c w h
+  BottomB    -> drawBorder (BottomBM 0) d p gc c w h
+  FullB      -> drawBorder (FullBM 0) d p gc c w h
+  TopBM m    -> sf >> drawLine d p gc 0 (fi m) (fi w) 0
+  BottomBM m -> let rw = fi h - fi m in
+                 sf >> drawLine d p gc 0 rw (fi w) rw
+  FullBM m   -> let pad = 2 * fi m; mp = fi m in
+                 sf >> drawRectangle d p gc mp mp (w - pad) (h - pad)
+  where sf = setForeground d gc c
+        (w, h) = (wi - 1, ht - 1)
+
+hideWindow :: Display -> Window -> IO ()
+hideWindow d w = do
+    a <- internAtom d "_NET_WM_STRUT_PARTIAL"    False
+    c <- internAtom d "CARDINAL"                 False
+    changeProperty32 d w a c propModeReplace $ replicate 12 0
+    unmapWindow d w
+    sync d False
+
+showWindow :: Display -> Window -> IO ()
+showWindow d w = mapWindow d w >> sync d False
+
+isMapped :: Display -> Window -> IO Bool
+isMapped d w = fmap ism $ getWindowAttributes d w
+    where ism (WindowAttributes { wa_map_state = wms }) = wms /= waIsUnmapped