From 579b787c66124c1bc67dfa7a4ad00f3a8e3611cb Mon Sep 17 00:00:00 2001 From: jao Date: Thu, 22 Sep 2022 22:05:33 +0100 Subject: import clean-ups --- src/Xmobar/Plugins/Monitors/Common/Types.hs | 2 +- src/Xmobar/X11/ColorCache.hs | 48 +++---- src/Xmobar/X11/Text.hs | 38 +++--- src/Xmobar/X11/Window.hs | 201 ++++++++++++++-------------- 4 files changed, 149 insertions(+), 140 deletions(-) diff --git a/src/Xmobar/Plugins/Monitors/Common/Types.hs b/src/Xmobar/Plugins/Monitors/Common/Types.hs index d09da8e..68d7a0e 100644 --- a/src/Xmobar/Plugins/Monitors/Common/Types.hs +++ b/src/Xmobar/Plugins/Monitors/Common/Types.hs @@ -116,7 +116,7 @@ getMonitorConfig MC{..} = do pBarBack <- readIORef barBack pBarFore <- readIORef barFore pBarWidth <- readIORef barWidth - pUseSuffix <- readIORef useSuffix + pUseSuffix <- readIORef useSuffix pNaString <- readIORef naString pMaxTotalWidth <- readIORef maxTotalWidth pMaxTotalWidthEllipsis <- readIORef maxTotalWidthEllipsis diff --git a/src/Xmobar/X11/ColorCache.hs b/src/Xmobar/X11/ColorCache.hs index b981775..a8a07cd 100644 --- a/src/Xmobar/X11/ColorCache.hs +++ b/src/Xmobar/X11/ColorCache.hs @@ -17,43 +17,45 @@ module Xmobar.X11.ColorCache(withColors) where -import Data.IORef -import System.IO.Unsafe (unsafePerformIO) -import Control.Monad.Trans (MonadIO, liftIO) -import Control.Exception (SomeException, handle) -import Graphics.X11.Xlib +import qualified Data.IORef as IO +import qualified System.IO.Unsafe as U -data DynPixel = DynPixel Bool Pixel +import qualified Control.Exception as E +import qualified Control.Monad.Trans as Tr -initColor :: Display -> String -> IO DynPixel -initColor dpy c = handle black $ initColor' dpy c +import qualified Graphics.X11.Xlib as X + +data DynPixel = DynPixel Bool X.Pixel + +initColor :: X.Display -> String -> IO DynPixel +initColor dpy c = E.handle black $ initColor' dpy c where - black :: SomeException -> IO DynPixel - black = const . return $ DynPixel False (blackPixel dpy $ defaultScreen dpy) + black :: E.SomeException -> IO DynPixel + black = const . return $ DynPixel False (X.blackPixel dpy $ X.defaultScreen dpy) -type ColorCache = [(String, Color)] +type ColorCache = [(String, X.Color)] {-# NOINLINE colorCache #-} -colorCache :: IORef ColorCache -colorCache = unsafePerformIO $ newIORef [] +colorCache :: IO.IORef ColorCache +colorCache = U.unsafePerformIO $ IO.newIORef [] -getCachedColor :: String -> IO (Maybe Color) -getCachedColor color_name = lookup color_name `fmap` readIORef colorCache +getCachedColor :: String -> IO (Maybe X.Color) +getCachedColor color_name = lookup color_name `fmap` IO.readIORef colorCache -putCachedColor :: String -> Color -> IO () -putCachedColor name c_id = modifyIORef colorCache $ \c -> (name, c_id) : c +putCachedColor :: String -> X.Color -> IO () +putCachedColor name c_id = IO.modifyIORef colorCache $ \c -> (name, c_id) : c -initColor' :: Display -> String -> IO DynPixel +initColor' :: X.Display -> String -> IO DynPixel initColor' dpy c = do - let colormap = defaultColormap dpy (defaultScreen dpy) + let colormap = X.defaultColormap dpy (X.defaultScreen dpy) cached_color <- getCachedColor c c' <- case cached_color of Just col -> return col - _ -> do (c'', _) <- allocNamedColor dpy colormap c + _ -> do (c'', _) <- X.allocNamedColor dpy colormap c putCachedColor c c'' return c'' - return $ DynPixel True (color_pixel c') + return $ DynPixel True (X.color_pixel c') -withColors :: MonadIO m => Display -> [String] -> ([Pixel] -> m a) -> m a +withColors :: Tr.MonadIO m => X.Display -> [String] -> ([X.Pixel] -> m a) -> m a withColors d cs f = do - ps <- mapM (liftIO . initColor d) cs + ps <- mapM (Tr.liftIO . initColor d) cs f $ map (\(DynPixel _ pixel) -> pixel) ps diff --git a/src/Xmobar/X11/Text.hs b/src/Xmobar/X11/Text.hs index 6da96fa..357ee3c 100644 --- a/src/Xmobar/X11/Text.hs +++ b/src/Xmobar/X11/Text.hs @@ -20,16 +20,16 @@ module Xmobar.X11.Text , textWidth ) where -import Control.Exception (SomeException, handle) +import qualified Control.Exception as E +import qualified Foreign as F +import qualified System.Mem.Weak as W -import Foreign -import Graphics.X11.Xlib hiding (textExtents, textWidth) -import Graphics.X11.Xlib.Extras -import System.Mem.Weak ( addFinalizer ) +import qualified Graphics.X11.Xlib as X +import qualified Graphics.X11.Xlib.Extras as Xx -type XFont = FontSet +type XFont = Xx.FontSet -initFont :: Display -> String -> IO XFont +initFont :: X.Display -> String -> IO XFont initFont = initUtf8Font miscFixedFont :: String @@ -37,21 +37,21 @@ miscFixedFont = "-misc-fixed-*-*-*-*-*-*-*-*-*-*-*-*" -- | Given a fontname returns the font structure. If the font name is -- not valid the default font will be loaded and returned. -initUtf8Font :: Display -> String -> IO FontSet +initUtf8Font :: X.Display -> String -> IO Xx.FontSet initUtf8Font d s = do - (_,_,f) <- handle fallBack getIt - addFinalizer f (freeFontSet d f) + (_,_,f) <- E.handle fallBack getIt + W.addFinalizer f (Xx.freeFontSet d f) return f - where getIt = createFontSet d s - fallBack :: SomeException -> IO ([String], String, FontSet) - fallBack = const $ createFontSet d miscFixedFont + where getIt = Xx.createFontSet d s + fallBack :: E.SomeException -> IO ([String], String, Xx.FontSet) + fallBack = const $ Xx.createFontSet d miscFixedFont -textWidth :: Display -> XFont -> String -> IO Int -textWidth _ fs s = return $ fromIntegral $ wcTextEscapement fs s +textWidth :: X.Display -> XFont -> String -> IO Int +textWidth _ fs s = return $ fromIntegral $ Xx.wcTextEscapement fs s -textExtents :: XFont -> String -> IO (Int32,Int32) +textExtents :: XFont -> String -> IO (F.Int32, F.Int32) textExtents fs s = do - let (_,rl) = wcTextExtents fs s - ascent = fromIntegral $ negate (rect_y rl) - descent = fromIntegral $ rect_height rl + fromIntegral (rect_y rl) + let (_,rl) = Xx.wcTextExtents fs s + ascent = fromIntegral $ negate (X.rect_y rl) + descent = fromIntegral $ X.rect_height rl + fromIntegral (X.rect_y rl) return (ascent, descent) diff --git a/src/Xmobar/X11/Window.hs b/src/Xmobar/X11/Window.hs index d42d74a..ad7ebf7 100644 --- a/src/Xmobar/X11/Window.hs +++ b/src/Xmobar/X11/Window.hs @@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Window --- Copyright : (c) 2011-18, 20, 21 Jose A. Ortega Ruiz +-- Copyright : (c) 2011-18, 2020-22 Jose A. Ortega Ruiz -- : (c) 2012 Jochen Keil -- License : BSD-style (see LICENSE) -- @@ -15,164 +15,171 @@ module Xmobar.X11.Window where -import Prelude -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 qualified Control.Monad as CM -import Data.Function (on) -import Data.List (maximumBy) -import Data.Maybe (fromMaybe) -import System.Posix.Process (getProcessID) +import qualified Data.Function as DF +import qualified Data.List as DL +import qualified Data.Maybe as DM -import Xmobar.Config.Types -import Xmobar.X11.Text +import qualified Graphics.X11.Xlib as X +import qualified Graphics.X11.Xlib.Extras as Xx + +import qualified Graphics.X11.Xinerama as Xi +import qualified Foreign.C.Types as C + +import qualified System.Posix.Process as PP + +import qualified Xmobar.Config.Types as T +import qualified Xmobar.X11.Text as Txt -- $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 $ +newWindow :: + X.Display -> X.Screen -> X.Window -> X.Rectangle -> Bool -> IO X.Window +newWindow dpy scr rw (X.Rectangle x y w h) o = do + let visual = X.defaultVisualOfScreen scr + attrmask = if o then X.cWOverrideRedirect else 0 + X.allocaSetWindowAttributes $ \attributes -> do - set_override_redirect attributes o - createWindow dpy rw x y w h 0 (defaultDepthOfScreen scr) - inputOutput visual attrmask attributes + X.set_override_redirect attributes o + X.createWindow dpy rw x y w h 0 (X.defaultDepthOfScreen scr) + X.inputOutput visual attrmask attributes -- | The function to create the initial window -createWin :: Display -> XFont -> Config -> IO (Rectangle,Window) +createWin :: X.Display -> Txt.XFont -> T.Config -> IO (X.Rectangle, X.Window) createWin d fs c = do - let dflt = defaultScreen d - srs <- getScreenInfo d - rootw <- rootWindow d dflt - (as,ds) <- textExtents fs "0" + let dflt = X.defaultScreen d + srs <- Xi.getScreenInfo d + rootw <- X.rootWindow d dflt + (as,ds) <- Txt.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) + r = setPosition c (T.position c) srs (fromIntegral ht) + win <- newWindow d (X.defaultScreenOfDisplay d) rootw r (T.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 + CM.when (T.lowerOnStart c) $ X.lowerWindow d win + CM.unless (T.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 :: X.Display -> X.Window -> Txt.XFont -> T.Config -> IO X.Rectangle repositionWin d win fs c = do - srs <- getScreenInfo d - (as,ds) <- textExtents fs "0" + srs <- Xi.getScreenInfo d + (as,ds) <- Txt.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) + r = setPosition c (T.position c) srs (fromIntegral ht) + X.moveResizeWindow d win + (X.rect_x r) (X.rect_y r) (X.rect_width r) (X.rect_height r) setStruts r c d win srs - sync d False + X.sync d False return r fi :: (Integral a, Num b) => a -> b fi = fromIntegral -setPosition :: Config -> XPosition -> [Rectangle] -> Dimension -> Rectangle +setPosition :: + T.Config -> T.XPosition -> [X.Rectangle] -> X.Dimension -> X.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 - TopH ch -> Rectangle rx ry rw (mh ch) - 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 - BottomH ch -> Rectangle rx (ny' ch) rw (mh ch) - 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 + T.Top -> X.Rectangle rx ry rw h + T.TopP l r -> X.Rectangle (rx + fi l) ry (rw - fi l - fi r) h + T.TopH ch -> X.Rectangle rx ry rw (mh ch) + T.TopW a i -> X.Rectangle (ax a i) ry (nw i) h + T.TopSize a i ch -> X.Rectangle (ax a i) ry (nw i) (mh ch) + T.Bottom -> X.Rectangle rx ny rw h + T.BottomH ch -> X.Rectangle rx (ny' ch) rw (mh ch) + T.BottomW a i -> X.Rectangle (ax a i) ny (nw i) h + T.BottomP l r -> X.Rectangle (rx + fi l) ny (rw - fi l - fi r) h + T.BottomSize a i ch -> X.Rectangle (ax a i) (ny' ch) (nw i) (mh ch) + T.Static cx cy cw ch -> X.Rectangle (fi cx) (fi cy) (fi cw) (fi ch) + T.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) + (scr@(X.Rectangle rx ry rw rh), p') = + case p of T.OnScreen i x -> (DM.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 + ax T.L = const rx + ax T.R = right + ax T.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) + picker = if T.pickBroadest c + then DL.maximumBy (compare `DF.on` X.rect_width) else head -setProperties :: Config -> Display -> Window -> IO () +setProperties :: T.Config -> X.Display -> X.Window -> IO () setProperties c d w = do - let mkatom n = internAtom d n False + let mkatom n = X.internAtom d n False card <- mkatom "CARDINAL" atom <- mkatom "ATOM" - setTextProperty d w (wmClass c) wM_CLASS - setTextProperty d w (wmName c) wM_NAME + X.setTextProperty d w (T.wmClass c) X.wM_CLASS + X.setTextProperty d w (T.wmName c) X.wM_NAME wtype <- mkatom "_NET_WM_WINDOW_TYPE" dock <- mkatom "_NET_WM_WINDOW_TYPE_DOCK" - changeProperty32 d w wtype atom propModeReplace [fi dock] + Xx.changeProperty32 d w wtype atom Xx.propModeReplace [fi dock] - when (allDesktops c) $ do + CM.when (T.allDesktops c) $ do desktop <- mkatom "_NET_WM_DESKTOP" - changeProperty32 d w desktop card propModeReplace [0xffffffff] + Xx.changeProperty32 d w desktop card Xx.propModeReplace [0xffffffff] pid <- mkatom "_NET_WM_PID" - getProcessID >>= changeProperty32 d w pid card propModeReplace . return . fi + PP.getProcessID >>= + Xx.changeProperty32 d w pid card Xx.propModeReplace . return . fi -setStruts' :: Display -> Window -> [Foreign.C.Types.CLong] -> IO () +setStruts' :: X.Display -> X.Window -> [C.CLong] -> IO () setStruts' d w svs = do - let mkatom n = internAtom d n False + let mkatom n = X.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) + Xx.changeProperty32 d w pstrut card Xx.propModeReplace svs + Xx.changeProperty32 d w strut card Xx.propModeReplace (take 4 svs) -setStruts :: Rectangle -> Config -> Display -> Window -> [Rectangle] -> IO () +setStruts :: + X.Rectangle -> T.Config -> X.Display -> X.Window -> [X.Rectangle] -> IO () setStruts r c d w rs = do - let svs = map fi $ getStrutValues r (position c) (getRootWindowHeight rs) + let svs = map fi $ getStrutValues r (T.position c) (getRootWindowHeight rs) setStruts' d w svs -getRootWindowHeight :: [Rectangle] -> Int +getRootWindowHeight :: [X.Rectangle] -> Int getRootWindowHeight srs = maximum (map getMaxScreenYCoord srs) where - getMaxScreenYCoord sr = fi (rect_y sr) + fi (rect_height sr) + getMaxScreenYCoord sr = fi (X.rect_y sr) + fi (X.rect_height sr) -getStrutValues :: Rectangle -> XPosition -> Int -> [Int] -getStrutValues r@(Rectangle x y w h) p rwh = +getStrutValues :: X.Rectangle -> T.XPosition -> Int -> [Int] +getStrutValues r@(X.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] - TopH _ -> [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] - BottomH _ -> [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 + T.OnScreen _ p' -> getStrutValues r p' rwh + T.Top -> [0, 0, st, 0, 0, 0, 0, 0, nx, nw, 0, 0] + T.TopH _ -> [0, 0, st, 0, 0, 0, 0, 0, nx, nw, 0, 0] + T.TopP _ _ -> [0, 0, st, 0, 0, 0, 0, 0, nx, nw, 0, 0] + T.TopW _ _ -> [0, 0, st, 0, 0, 0, 0, 0, nx, nw, 0, 0] + T.TopSize {} -> [0, 0, st, 0, 0, 0, 0, 0, nx, nw, 0, 0] + T.Bottom -> [0, 0, 0, sb, 0, 0, 0, 0, 0, 0, nx, nw] + T.BottomH _ -> [0, 0, 0, sb, 0, 0, 0, 0, 0, 0, nx, nw] + T.BottomP _ _ -> [0, 0, 0, sb, 0, 0, 0, 0, 0, 0, nx, nw] + T.BottomW _ _ -> [0, 0, 0, sb, 0, 0, 0, 0, 0, 0, nx, nw] + T.BottomSize {} -> [0, 0, 0, sb, 0, 0, 0, 0, 0, 0, nx, nw] + T.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 +getStaticStrutValues :: T.XPosition -> Int -> [Int] +getStaticStrutValues (T.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] @@ -183,17 +190,17 @@ getStaticStrutValues (Static cx cy cw ch) rwh xe = xs + cw - 1 getStaticStrutValues _ _ = [0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0] -hideWindow :: Display -> Window -> IO () +hideWindow :: X.Display -> X.Window -> IO () hideWindow d w = do setStruts' d w (replicate 12 0) - unmapWindow d w >> sync d False + Xx.unmapWindow d w >> X.sync d False -showWindow :: Rectangle -> Config -> Display -> Window -> IO () +showWindow :: X.Rectangle -> T.Config -> X.Display -> X.Window -> IO () showWindow r c d w = do - mapWindow d w - getScreenInfo d >>= setStruts r c d w - sync d False + X.mapWindow d w + Xi.getScreenInfo d >>= setStruts r c d w + X.sync d False -isMapped :: Display -> Window -> IO Bool -isMapped d w = ism <$> getWindowAttributes d w - where ism WindowAttributes { wa_map_state = wms } = wms /= waIsUnmapped +isMapped :: X.Display -> X.Window -> IO Bool +isMapped d w = ism <$> Xx.getWindowAttributes d w + where ism Xx.WindowAttributes { Xx.wa_map_state = wms } = wms /= Xx.waIsUnmapped -- cgit v1.2.3