From 77df1ac30fa7af5948f7ff64f5fee9aed64552b3 Mon Sep 17 00:00:00 2001 From: jao Date: Sun, 25 Nov 2018 15:10:29 +0000 Subject: Back to app/src, since it seems they're the default convention for stack --- src/Xmobar/X11/Window.hs | 229 +++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 229 insertions(+) create mode 100644 src/Xmobar/X11/Window.hs (limited to 'src/Xmobar/X11/Window.hs') diff --git a/src/Xmobar/X11/Window.hs b/src/Xmobar/X11/Window.hs new file mode 100644 index 0000000..78f4b26 --- /dev/null +++ b/src/Xmobar/X11/Window.hs @@ -0,0 +1,229 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Window +-- Copyright : (c) 2011-18 Jose A. Ortega Ruiz +-- : (c) 2012 Jochen Keil +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Jose A. Ortega Ruiz +-- Stability : unstable +-- Portability : unportable +-- +-- Window manipulation functions +-- +----------------------------------------------------------------------------- + +module Xmobar.X11.Window where + +import Prelude +import Control.Applicative ((<$>)) +import Control.Monad (when, unless) +import Graphics.X11.Xlib hiding (textExtents) +import Graphics.X11.Xlib.Extras +import Graphics.X11.Xinerama +import Foreign.C.Types (CLong) + +import Data.Function (on) +import Data.List (maximumBy) +import Data.Maybe (fromMaybe) +import System.Posix.Process (getProcessID) + +import Xmobar.Config +import Xmobar.X11.XUtil + +-- $window + +-- | Creates a window with the attribute override_redirect set to True. +-- Windows Managers should not touch this kind of windows. +newWindow :: Display -> Screen -> Window -> Rectangle -> Bool -> IO Window +newWindow dpy scr rw (Rectangle x y w h) o = do + let visual = defaultVisualOfScreen scr + attrmask = if o then cWOverrideRedirect else 0 + allocaSetWindowAttributes $ + \attributes -> do + set_override_redirect attributes o + createWindow dpy rw x y w h 0 (defaultDepthOfScreen scr) + inputOutput visual attrmask attributes + +-- | 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 = setPosition c (position c) srs (fromIntegral ht) + win <- newWindow d (defaultScreenOfDisplay d) rootw r (overrideRedirect c) + setProperties c d win + setStruts r c d win srs + when (lowerOnStart c) $ lowerWindow d win + unless (hideOnStart c) $ showWindow r c 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 c (position c) srs (fromIntegral ht) + moveResizeWindow d win (rect_x r) (rect_y r) (rect_width r) (rect_height r) + setStruts r c d win srs + return r + +fi :: (Integral a, Num b) => a -> b +fi = fromIntegral + +setPosition :: Config -> XPosition -> [Rectangle] -> Dimension -> Rectangle +setPosition c p rs ht = + case p' of + Top -> Rectangle rx ry rw h + TopP l r -> Rectangle (rx + fi l) ry (rw - fi l - fi r) h + TopW a i -> Rectangle (ax a i) ry (nw i) h + TopSize a i ch -> Rectangle (ax a i) ry (nw i) (mh ch) + Bottom -> Rectangle rx ny rw h + BottomW a i -> Rectangle (ax a i) ny (nw i) h + BottomP l r -> Rectangle (rx + fi l) ny (rw - fi l - fi r) h + BottomSize a i ch -> Rectangle (ax a i) (ny' ch) (nw i) (mh ch) + Static cx cy cw ch -> Rectangle (fi cx) (fi cy) (fi cw) (fi ch) + OnScreen _ p'' -> setPosition c p'' [scr] ht + where + (scr@(Rectangle rx ry rw rh), p') = + case p of OnScreen i x -> (fromMaybe (picker rs) $ safeIndex i rs, x) + _ -> (picker 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..] + picker = if pickBroadest c + then maximumBy (compare `on` rect_width) + else head + +setProperties :: Config -> Display -> Window -> IO () +setProperties c d w = do + let mkatom n = internAtom d n False + card <- mkatom "CARDINAL" + atom <- mkatom "ATOM" + + setTextProperty d w (wmClass c) wM_CLASS + setTextProperty d w (wmName c) wM_NAME + + wtype <- mkatom "_NET_WM_WINDOW_TYPE" + dock <- mkatom "_NET_WM_WINDOW_TYPE_DOCK" + changeProperty32 d w wtype atom propModeReplace [fi dock] + + when (allDesktops c) $ do + desktop <- mkatom "_NET_WM_DESKTOP" + changeProperty32 d w desktop card propModeReplace [0xffffffff] + + pid <- mkatom "_NET_WM_PID" + getProcessID >>= changeProperty32 d w pid card propModeReplace . return . fi + +setStruts' :: Display -> Window -> [Foreign.C.Types.CLong] -> IO () +setStruts' d w svs = do + let mkatom n = internAtom d n False + card <- mkatom "CARDINAL" + pstrut <- mkatom "_NET_WM_STRUT_PARTIAL" + strut <- mkatom "_NET_WM_STRUT" + changeProperty32 d w pstrut card propModeReplace svs + changeProperty32 d w strut card propModeReplace (take 4 svs) + +setStruts :: Rectangle -> Config -> Display -> Window -> [Rectangle] -> IO () +setStruts r c d w rs = do + let svs = map fi $ getStrutValues r (position c) (getRootWindowHeight rs) + setStruts' d w svs + +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] + TopP _ _ -> [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] + BottomP _ _ -> [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 -> Int -> Display -> Drawable -> GC -> Pixel + -> Dimension -> Dimension -> IO () +drawBorder b lw d p gc c wi ht = case b of + NoBorder -> return () + TopB -> drawBorder (TopBM 0) lw d p gc c wi ht + BottomB -> drawBorder (BottomBM 0) lw d p gc c wi ht + FullB -> drawBorder (FullBM 0) lw d p gc c wi ht + TopBM m -> sf >> sla >> + drawLine d p gc 0 (fi m + boff) (fi wi) (fi m + boff) + BottomBM m -> let rw = fi ht - fi m + boff in + sf >> sla >> drawLine d p gc 0 rw (fi wi) rw + FullBM m -> let mp = fi m + pad = 2 * fi mp + fi lw + in sf >> sla >> + drawRectangle d p gc mp mp (wi - pad) (ht - pad) + where sf = setForeground d gc c + sla = setLineAttributes d gc (fi lw) lineSolid capNotLast joinMiter + boff = borderOffset b lw +-- boff' = calcBorderOffset lw :: Int + +hideWindow :: Display -> Window -> IO () +hideWindow d w = do + setStruts' d w (replicate 12 0) + unmapWindow d w >> sync d False + +showWindow :: Rectangle -> Config -> Display -> Window -> IO () +showWindow r c d w = do + mapWindow d w + getScreenInfo d >>= setStruts r c d w + sync d False + +isMapped :: Display -> Window -> IO Bool +isMapped d w = ism <$> getWindowAttributes d w + where ism WindowAttributes { wa_map_state = wms } = wms /= waIsUnmapped + +borderOffset :: (Integral a) => Border -> Int -> a +borderOffset b lw = + case b of + BottomB -> negate boffs + BottomBM _ -> negate boffs + TopB -> boffs + TopBM _ -> boffs + _ -> 0 + where boffs = calcBorderOffset lw + +calcBorderOffset :: (Integral a) => Int -> a +calcBorderOffset = ceiling . (/2) . toDouble + where toDouble = fi :: (Integral a) => a -> Double -- cgit v1.2.3