From 658dd00771852286bb9ce007d11db869c237d934 Mon Sep 17 00:00:00 2001 From: jao Date: Sun, 25 Nov 2018 03:08:40 +0000 Subject: Refactoring: Xmobar.X11 --- src/lib/Xmobar.hs | 13 +- src/lib/Xmobar/Bitmap.hs | 130 --------------- src/lib/Xmobar/ColorCache.hs | 110 ------------- src/lib/Xmobar/Draw.hs | 123 --------------- src/lib/Xmobar/EventLoop.hs | 249 ----------------------------- src/lib/Xmobar/MinXft.hsc | 333 --------------------------------------- src/lib/Xmobar/Types.hs | 47 ------ src/lib/Xmobar/Window.hs | 229 --------------------------- src/lib/Xmobar/X11/Bitmap.hs | 130 +++++++++++++++ src/lib/Xmobar/X11/ColorCache.hs | 110 +++++++++++++ src/lib/Xmobar/X11/Draw.hs | 151 ++++++++++++++++++ src/lib/Xmobar/X11/EventLoop.hs | 252 +++++++++++++++++++++++++++++ src/lib/Xmobar/X11/MinXft.hsc | 333 +++++++++++++++++++++++++++++++++++++++ src/lib/Xmobar/X11/Types.hs | 40 +++++ src/lib/Xmobar/X11/Window.hs | 229 +++++++++++++++++++++++++++ src/lib/Xmobar/X11/XUtil.hs | 129 +++++++++++++++ src/lib/Xmobar/XUtil.hs | 160 ------------------- xmobar.cabal | 40 +++-- 18 files changed, 1399 insertions(+), 1409 deletions(-) delete mode 100644 src/lib/Xmobar/Bitmap.hs delete mode 100644 src/lib/Xmobar/ColorCache.hs delete mode 100644 src/lib/Xmobar/Draw.hs delete mode 100644 src/lib/Xmobar/EventLoop.hs delete mode 100644 src/lib/Xmobar/MinXft.hsc delete mode 100644 src/lib/Xmobar/Types.hs delete mode 100644 src/lib/Xmobar/Window.hs create mode 100644 src/lib/Xmobar/X11/Bitmap.hs create mode 100644 src/lib/Xmobar/X11/ColorCache.hs create mode 100644 src/lib/Xmobar/X11/Draw.hs create mode 100644 src/lib/Xmobar/X11/EventLoop.hs create mode 100644 src/lib/Xmobar/X11/MinXft.hsc create mode 100644 src/lib/Xmobar/X11/Types.hs create mode 100644 src/lib/Xmobar/X11/Window.hs create mode 100644 src/lib/Xmobar/X11/XUtil.hs delete mode 100644 src/lib/Xmobar/XUtil.hs diff --git a/src/lib/Xmobar.hs b/src/lib/Xmobar.hs index 547c549..2b160a1 100644 --- a/src/lib/Xmobar.hs +++ b/src/lib/Xmobar.hs @@ -17,10 +17,6 @@ module Xmobar (xmobar, Runnable (..), module Xmobar.Config) where -import Xmobar.EventLoop (startLoop, startCommand) -import Xmobar.Config -import Xmobar.Runnable - import Data.Foldable (for_) import qualified Data.Map as Map @@ -28,11 +24,14 @@ import Graphics.X11.Xlib import Control.Concurrent.Async (Async, cancel) import Control.Exception (bracket) +import Xmobar.Config +import Xmobar.Runnable import Xmobar.Parsers -import Xmobar.XUtil import Xmobar.Signal (setupSignalHandler, withDeferSignals) -import Xmobar.Window -import Xmobar.Types +import Xmobar.X11.Types +import Xmobar.X11.EventLoop (startLoop, startCommand) +import Xmobar.X11.XUtil +import Xmobar.X11.Window splitTemplate :: Config -> [String] splitTemplate conf = diff --git a/src/lib/Xmobar/Bitmap.hs b/src/lib/Xmobar/Bitmap.hs deleted file mode 100644 index 314ce02..0000000 --- a/src/lib/Xmobar/Bitmap.hs +++ /dev/null @@ -1,130 +0,0 @@ -{-# LANGUAGE CPP, FlexibleContexts #-} ------------------------------------------------------------------------------ --- | --- Module : Bitmap --- Copyright : (C) 2013, 2015, 2017, 2018 Alexander Polakov --- License : BSD3 --- --- Maintainer : jao@gnu.org --- Stability : unstable --- Portability : unportable --- ------------------------------------------------------------------------------ - -module Xmobar.Bitmap - ( updateCache - , drawBitmap - , Bitmap(..)) where - -import Control.Monad -import Control.Monad.Trans(MonadIO(..)) -import Data.Map hiding (map, filter) -import Graphics.X11.Xlib -import System.Directory (doesFileExist) -import System.FilePath (()) -import System.Mem.Weak ( addFinalizer ) -import Xmobar.ColorCache -import Xmobar.Parsers (Widget(..)) -import Xmobar.Actions (Action) - -#ifdef XPM -import Xmobar.XPMFile(readXPMFile) -import Control.Applicative((<|>)) -#endif - -#if MIN_VERSION_mtl(2, 2, 1) -import Control.Monad.Except(MonadError(..), runExceptT) - -#else -import Control.Monad.Error(MonadError(..)) -import Control.Monad.Trans.Error(ErrorT, runErrorT) - -runExceptT :: ErrorT e m a -> m (Either e a) -runExceptT = runErrorT - -#endif - -data BitmapType = Mono Pixel | Poly - -data Bitmap = Bitmap { width :: Dimension - , height :: Dimension - , pixmap :: Pixmap - , shapePixmap :: Maybe Pixmap - , bitmapType :: BitmapType - } - -updateCache :: Display -> Window -> Map FilePath Bitmap -> FilePath -> - [[(Widget, String, Int, Maybe [Action])]] -> IO (Map FilePath Bitmap) -updateCache dpy win cache iconRoot ps = do - let paths = map (\(Icon p, _, _, _) -> p) . concatMap (filter icons) $ ps - icons (Icon _, _, _, _) = True - icons _ = False - expandPath path@('/':_) = path - expandPath path@('.':'/':_) = path - expandPath path@('.':'.':'/':_) = path - expandPath path = iconRoot path - go m path = if member path m - then return m - else do bitmap <- loadBitmap dpy win $ expandPath path - return $ maybe m (\b -> insert path b m) bitmap - foldM go cache paths - -readBitmapFile' - :: (MonadError String m, MonadIO m) - => Display - -> Drawable - -> String - -> m (Dimension, Dimension, Pixmap) -readBitmapFile' d w p = do - res <- liftIO $ readBitmapFile d w p - case res of - Left err -> throwError err - Right (bw, bh, bp, _, _) -> return (bw, bh, bp) - -loadBitmap :: Display -> Drawable -> FilePath -> IO (Maybe Bitmap) -loadBitmap d w p = do - exist <- doesFileExist p - if exist - then do -#ifdef XPM - res <- runExceptT (tryXBM <|> tryXPM) -#else - res <- runExceptT tryXBM -#endif - case res of - Right b -> return $ Just b - Left err -> do - putStrLn err - return Nothing - else - return Nothing - where tryXBM = do - (bw, bh, bp) <- readBitmapFile' d w p - liftIO $ addFinalizer bp (freePixmap d bp) - return $ Bitmap bw bh bp Nothing (Mono 1) -#ifdef XPM - tryXPM = do - (bw, bh, bp, mbpm) <- readXPMFile d w p - liftIO $ addFinalizer bp (freePixmap d bp) - case mbpm of - Nothing -> return () - Just bpm -> liftIO $ addFinalizer bpm (freePixmap d bpm) - return $ Bitmap bw bh bp mbpm Poly -#endif - -drawBitmap :: Display -> Drawable -> GC -> String -> String - -> Position -> Position -> Bitmap -> IO () -drawBitmap d p gc fc bc x y i = - withColors d [fc, bc] $ \[fc', bc'] -> do - let w = width i - h = height i - y' = 1 + y - fromIntegral h `div` 2 - setForeground d gc fc' - setBackground d gc bc' - case shapePixmap i of - Nothing -> return () - Just mask -> setClipOrigin d gc x y' >> setClipMask d gc mask - case bitmapType i of - Poly -> copyArea d (pixmap i) p gc 0 0 w h x y' - Mono pl -> copyPlane d (pixmap i) p gc 0 0 w h x y' pl - setClipMask d gc 0 diff --git a/src/lib/Xmobar/ColorCache.hs b/src/lib/Xmobar/ColorCache.hs deleted file mode 100644 index f17aa0d..0000000 --- a/src/lib/Xmobar/ColorCache.hs +++ /dev/null @@ -1,110 +0,0 @@ -{-# LANGUAGE CPP #-} ------------------------------------------------------------------------------- --- | --- Module: ColorCache --- Copyright: (c) 2012 Jose Antonio Ortega Ruiz --- License: BSD3-style (see LICENSE) --- --- Maintainer: jao@gnu.org --- Stability: unstable --- Portability: unportable --- Created: Mon Sep 10, 2012 00:27 --- --- --- Caching X colors --- ------------------------------------------------------------------------------- - -#if defined XFT - -module Xmobar.ColorCache(withColors, withDrawingColors) where - -import Xmobar.MinXft - -#else -module Xmobar.ColorCache(withColors) where - -#endif - -import Data.IORef -import System.IO.Unsafe (unsafePerformIO) -import Control.Monad.Trans (MonadIO, liftIO) -import Control.Exception (SomeException, handle) -import Graphics.X11.Xlib - -data DynPixel = DynPixel Bool Pixel - -initColor :: Display -> String -> IO DynPixel -initColor dpy c = handle black $ initColor' dpy c - where - black :: SomeException -> IO DynPixel - black = const . return $ DynPixel False (blackPixel dpy $ defaultScreen dpy) - -type ColorCache = [(String, Color)] -{-# NOINLINE colorCache #-} -colorCache :: IORef ColorCache -colorCache = unsafePerformIO $ newIORef [] - -getCachedColor :: String -> IO (Maybe Color) -getCachedColor color_name = lookup color_name `fmap` readIORef colorCache - -putCachedColor :: String -> Color -> IO () -putCachedColor name c_id = modifyIORef colorCache $ \c -> (name, c_id) : c - -initColor' :: Display -> String -> IO DynPixel -initColor' dpy c = do - let colormap = defaultColormap dpy (defaultScreen dpy) - cached_color <- getCachedColor c - c' <- case cached_color of - Just col -> return col - _ -> do (c'', _) <- allocNamedColor dpy colormap c - putCachedColor c c'' - return c'' - return $ DynPixel True (color_pixel c') - -withColors :: MonadIO m => Display -> [String] -> ([Pixel] -> m a) -> m a -withColors d cs f = do - ps <- mapM (liftIO . initColor d) cs - f $ map (\(DynPixel _ pixel) -> pixel) ps - -#ifdef XFT - -type AXftColorCache = [(String, AXftColor)] -{-# NOINLINE xftColorCache #-} -xftColorCache :: IORef AXftColorCache -xftColorCache = unsafePerformIO $ newIORef [] - -getXftCachedColor :: String -> IO (Maybe AXftColor) -getXftCachedColor name = lookup name `fmap` readIORef xftColorCache - -putXftCachedColor :: String -> AXftColor -> IO () -putXftCachedColor name cptr = - modifyIORef xftColorCache $ \c -> (name, cptr) : c - -initAXftColor' :: Display -> Visual -> Colormap -> String -> IO AXftColor -initAXftColor' d v cm c = do - cc <- getXftCachedColor c - c' <- case cc of - Just col -> return col - _ -> do c'' <- mallocAXftColor d v cm c - putXftCachedColor c c'' - return c'' - return c' - -initAXftColor :: Display -> Visual -> Colormap -> String -> IO AXftColor -initAXftColor d v cm c = handle black $ (initAXftColor' d v cm c) - where - black :: SomeException -> IO AXftColor - black = (const $ initAXftColor' d v cm "black") - -withDrawingColors :: -- MonadIO m => - Display -> Drawable -> String -> String - -> (AXftDraw -> AXftColor -> AXftColor -> IO ()) -> IO () -withDrawingColors dpy drw fc bc f = do - let screen = defaultScreenOfDisplay dpy - colormap = defaultColormapOfScreen screen - visual = defaultVisualOfScreen screen - fc' <- initAXftColor dpy visual colormap fc - bc' <- initAXftColor dpy visual colormap bc - withAXftDraw dpy drw visual colormap $ \draw -> f draw fc' bc' -#endif diff --git a/src/lib/Xmobar/Draw.hs b/src/lib/Xmobar/Draw.hs deleted file mode 100644 index e63cd27..0000000 --- a/src/lib/Xmobar/Draw.hs +++ /dev/null @@ -1,123 +0,0 @@ -{-# LANGUAGE CPP #-} - ------------------------------------------------------------------------------- --- | --- Module: Xmobar.Draw --- Copyright: (c) 2018 Jose Antonio Ortega Ruiz --- License: BSD3-style (see LICENSE) --- --- Maintainer: jao@gnu.org --- Stability: unstable --- Portability: portable --- Created: Sat Nov 24, 2018 18:49 --- --- --- Drawing the xmobar contents --- ------------------------------------------------------------------------------- - - -module Xmobar.Draw (drawInWin) where - -import Prelude hiding (lookup) -import Control.Monad.IO.Class -import Control.Monad.Reader -import Control.Arrow ((&&&)) -import Data.Map hiding (foldr, map, filter) - -import Graphics.X11.Xlib hiding (textExtents, textWidth) - -import Xmobar.Parsers (Widget(..)) -import Xmobar.Actions (Action(..)) -import qualified Xmobar.Bitmap as B -import Xmobar.Types -import Xmobar.XUtil -import Xmobar.Config -import Xmobar.ColorCache -import Xmobar.Window (drawBorder) - -#ifdef XFT -import Xmobar.MinXft (drawBackground) -#endif - -fi :: (Integral a, Num b) => a -> b -fi = fromIntegral - --- | Draws in and updates the window -drawInWin :: Rectangle -> [[(Widget, String, Int, Maybe [Action])]] -> X () -drawInWin wr@(Rectangle _ _ wid ht) ~[left,center,right] = do - r <- ask - let (c,d) = (config &&& display) r - (w,(fs,vs)) = (window &&& fontListS &&& verticalOffsets) r - strLn = liftIO . mapM getWidth - iconW i = maybe 0 B.width (lookup i $ iconS r) - getWidth (Text s,cl,i,_) = - textWidth d (fs!!i) s >>= \tw -> return (Text s,cl,i,fi tw) - getWidth (Icon s,cl,i,_) = return (Icon s,cl,i,fi $ iconW s) - - p <- liftIO $ createPixmap d w wid ht - (defaultDepthOfScreen (defaultScreenOfDisplay d)) -#if XFT - when (alpha c /= 255) (liftIO $ drawBackground d p (bgColor c) (alpha c) wr) -#endif - withColors d [bgColor c, borderColor c] $ \[bgcolor, bdcolor] -> do - gc <- liftIO $ createGC d w -#if XFT - when (alpha c == 255) $ do -#else - do -#endif - liftIO $ setForeground d gc bgcolor - liftIO $ fillRectangle d p gc 0 0 wid ht - -- write to the pixmap the new string - printStrings p gc fs vs 1 L =<< strLn left - printStrings p gc fs vs 1 R =<< strLn right - printStrings p gc fs vs 1 C =<< strLn center - -- draw border if requested - liftIO $ drawBorder (border c) (borderWidth c) d p gc bdcolor wid ht - -- copy the pixmap with the new string to the window - liftIO $ copyArea d p w gc 0 0 wid ht 0 0 - -- free up everything (we do not want to leak memory!) - liftIO $ freeGC d gc - liftIO $ freePixmap d p - -- resync - liftIO $ sync d True - -verticalOffset :: (Integral b, Integral a, MonadIO m) => - a -> Widget -> XFont -> Int -> Config -> m b -verticalOffset ht (Text t) fontst voffs _ - | voffs > -1 = return $ fi voffs - | otherwise = do - (as,ds) <- liftIO $ textExtents fontst t - let margin = (fi ht - fi ds - fi as) `div` 2 - return $ fi as + margin - 1 -verticalOffset ht (Icon _) _ _ conf - | iconOffset conf > -1 = return $ fi (iconOffset conf) - | otherwise = return $ fi (ht `div` 2) - 1 - --- | An easy way to print the stuff we need to print -printStrings :: Drawable -> GC -> [XFont] -> [Int] -> Position - -> Align -> [(Widget, String, Int, Position)] -> X () -printStrings _ _ _ _ _ _ [] = return () -printStrings dr gc fontlist voffs offs a sl@((s,c,i,l):xs) = do - r <- ask - let (conf,d) = (config &&& display) r - alph = alpha conf - Rectangle _ _ wid ht = rect r - totSLen = foldr (\(_,_,_,len) -> (+) len) 0 sl - remWidth = fi wid - fi totSLen - fontst = fontlist !! i - offset = case a of - C -> (remWidth + offs) `div` 2 - R -> remWidth - L -> offs - (fc,bc) = case break (==',') c of - (f,',':b) -> (f, b ) - (f, _) -> (f, bgColor conf) - valign <- verticalOffset ht s (head fontlist) (voffs !! i) conf - case s of - (Text t) -> liftIO $ printString d dr fontst gc fc bc offset valign t alph - (Icon p) -> liftIO $ maybe (return ()) - (B.drawBitmap d dr gc fc bc offset valign) - (lookup p (iconS r)) - printStrings dr gc fontlist voffs (offs + l) a xs diff --git a/src/lib/Xmobar/EventLoop.hs b/src/lib/Xmobar/EventLoop.hs deleted file mode 100644 index 00f7465..0000000 --- a/src/lib/Xmobar/EventLoop.hs +++ /dev/null @@ -1,249 +0,0 @@ -{-# LANGUAGE CPP #-} - ------------------------------------------------------------------------------- --- | --- Module: Xmobar.EventLoop --- Copyright: (c) 2018 Jose Antonio Ortega Ruiz --- License: BSD3-style (see LICENSE) --- --- Maintainer: jao@gnu.org --- Stability: unstable --- Portability: portable --- Created: Sat Nov 24, 2018 19:40 --- --- --- Event loop --- ------------------------------------------------------------------------------- - - -module Xmobar.EventLoop (startLoop, startCommand) where - -import Prelude hiding (lookup) -import Graphics.X11.Xlib hiding (textExtents, textWidth) -import Graphics.X11.Xlib.Extras -import Graphics.X11.Xinerama -import Graphics.X11.Xrandr - -import Control.Arrow ((&&&)) -import Control.Applicative ((<$>)) -import Control.Monad.Reader -import Control.Concurrent -import Control.Concurrent.Async (Async, async) -import Control.Concurrent.STM -import Control.Exception (handle, SomeException(..)) -import Data.Bits -import Data.Map hiding (foldr, map, filter) -import Data.Maybe (fromJust, isJust) - -import Xmobar.Bitmap as Bitmap -import Xmobar.Config -import Xmobar.Parsers -import Xmobar.Commands -import Xmobar.Actions -import Xmobar.Runnable -import Xmobar.Signal -import Xmobar.Window -import Xmobar.XUtil -import Xmobar.Utils -import Xmobar.Draw -import Xmobar.Types - -#ifdef XFT -import Graphics.X11.Xft -#endif - -#ifdef DBUS -import Xmobar.IPC.DBus -#endif - --- | Starts the main event loop and threads -startLoop :: XConf -> TMVar SignalType -> [[([Async ()], TVar String)]] - -> IO () -startLoop xcfg@(XConf _ _ w _ _ _ _) sig vs = do -#ifdef XFT - xftInitFtLibrary -#endif - tv <- atomically $ newTVar [] - _ <- forkIO (handle (handler "checker") (checker tv [] vs sig)) -#ifdef THREADED_RUNTIME - _ <- forkOS (handle (handler "eventer") (eventer sig)) -#else - _ <- forkIO (handle (handler "eventer") (eventer sig)) -#endif -#ifdef DBUS - runIPC sig -#endif - eventLoop tv xcfg [] sig - where - handler thing (SomeException e) = - void $ putStrLn ("Thread " ++ thing ++ " failed: " ++ show e) - -- Reacts on events from X - eventer signal = - allocaXEvent $ \e -> do - dpy <- openDisplay "" - xrrSelectInput dpy (defaultRootWindow dpy) rrScreenChangeNotifyMask - selectInput dpy w (exposureMask .|. structureNotifyMask .|. buttonPressMask) - - forever $ do -#ifdef THREADED_RUNTIME - nextEvent dpy e -#else - nextEvent' dpy e -#endif - ev <- getEvent e - case ev of - ConfigureEvent {} -> atomically $ putTMVar signal Reposition - ExposeEvent {} -> atomically $ putTMVar signal Wakeup - RRScreenChangeNotifyEvent {} -> atomically $ putTMVar signal Reposition - ButtonEvent {} -> atomically $ putTMVar signal (Action (ev_button ev) (fi $ ev_x ev)) - _ -> return () - --- | Send signal to eventLoop every time a var is updated -checker :: TVar [String] - -> [String] - -> [[([Async ()], TVar String)]] - -> TMVar SignalType - -> IO () -checker tvar ov vs signal = do - nval <- atomically $ do - nv <- mapM concatV vs - guard (nv /= ov) - writeTVar tvar nv - return nv - atomically $ putTMVar signal Wakeup - checker tvar nval vs signal - where - concatV = fmap concat . mapM (readTVar . snd) - - --- | Continuously wait for a signal from a thread or a interrupt handler -eventLoop :: TVar [String] - -> XConf - -> [([Action], Position, Position)] - -> TMVar SignalType - -> IO () -eventLoop tv xc@(XConf d r w fs vos is cfg) as signal = do - typ <- atomically $ takeTMVar signal - case typ of - Wakeup -> do - str <- updateString cfg tv - xc' <- updateCache d w is (iconRoot cfg) str >>= - \c -> return xc { iconS = c } - as' <- updateActions xc r str - runX xc' $ drawInWin r str - eventLoop tv xc' as' signal - - Reposition -> - reposWindow cfg - - ChangeScreen -> do - ncfg <- updateConfigPosition cfg - reposWindow ncfg - - Hide t -> hide (t*100*1000) - Reveal t -> reveal (t*100*1000) - Toggle t -> toggle t - - TogglePersistent -> eventLoop - tv xc { config = cfg { persistent = not $ persistent cfg } } as signal - - Action but x -> action but x - - where - isPersistent = not $ persistent cfg - - hide t - | t == 0 = - when isPersistent (hideWindow d w) >> eventLoop tv xc as signal - | otherwise = do - void $ forkIO - $ threadDelay t >> atomically (putTMVar signal $ Hide 0) - eventLoop tv xc as signal - - reveal t - | t == 0 = do - when isPersistent (showWindow r cfg d w) - eventLoop tv xc as signal - | otherwise = do - void $ forkIO - $ threadDelay t >> atomically (putTMVar signal $ Reveal 0) - eventLoop tv xc as signal - - toggle t = do - ismapped <- isMapped d w - atomically (putTMVar signal $ if ismapped then Hide t else Reveal t) - eventLoop tv xc as signal - - reposWindow rcfg = do - r' <- repositionWin d w (head fs) rcfg - eventLoop tv (XConf d r' w fs vos is rcfg) as signal - - updateConfigPosition ocfg = - case position ocfg of - OnScreen n o -> do - srs <- getScreenInfo d - return (if n == length srs - then - (ocfg {position = OnScreen 1 o}) - else - (ocfg {position = OnScreen (n+1) o})) - o -> return (ocfg {position = OnScreen 1 o}) - - action button x = do - mapM_ runAction $ - filter (\(Spawn b _) -> button `elem` b) $ - concatMap (\(a,_,_) -> a) $ - filter (\(_, from, to) -> x >= from && x <= to) as - eventLoop tv xc as signal - --- $command - --- | Runs a command as an independent thread and returns its Async handles --- and the TVar the command will be writing to. -startCommand :: TMVar SignalType - -> (Runnable,String,String) - -> IO ([Async ()], TVar String) -startCommand sig (com,s,ss) - | alias com == "" = do var <- atomically $ newTVar is - atomically $ writeTVar var (s ++ ss) - return ([], var) - | otherwise = do var <- atomically $ newTVar is - let cb str = atomically $ writeTVar var (s ++ str ++ ss) - a1 <- async $ start com cb - a2 <- async $ trigger com $ maybe (return ()) - (atomically . putTMVar sig) - return ([a1, a2], var) - where is = s ++ "Updating..." ++ ss - -updateString :: Config -> TVar [String] - -> IO [[(Widget, String, Int, Maybe [Action])]] -updateString conf v = do - s <- readTVarIO v - let l:c:r:_ = s ++ repeat "" - liftIO $ mapM (parseString conf) [l, c, r] - -updateActions :: XConf -> Rectangle -> [[(Widget, String, Int, Maybe [Action])]] - -> IO [([Action], Position, Position)] -updateActions conf (Rectangle _ _ wid _) ~[left,center,right] = do - let (d,fs) = (display &&& fontListS) conf - strLn :: [(Widget, String, Int, Maybe [Action])] -> IO [(Maybe [Action], Position, Position)] - strLn = liftIO . mapM getCoords - iconW i = maybe 0 Bitmap.width (lookup i $ iconS conf) - getCoords (Text s,_,i,a) = textWidth d (fs!!i) s >>= \tw -> return (a, 0, fi tw) - getCoords (Icon s,_,_,a) = return (a, 0, fi $ iconW s) - partCoord off xs = map (\(a, x, x') -> (fromJust a, x, x')) $ - filter (\(a, _,_) -> isJust a) $ - scanl (\(_,_,x') (a,_,w') -> (a, x', x' + w')) - (Nothing, 0, off) - xs - totSLen = foldr (\(_,_,len) -> (+) len) 0 - remWidth xs = fi wid - totSLen xs - offs = 1 - offset a xs = case a of - C -> (remWidth xs + offs) `div` 2 - R -> remWidth xs - L -> offs - fmap concat $ mapM (\(a,xs) -> - (\xs' -> partCoord (offset a xs') xs') <$> strLn xs) $ - zip [L,C,R] [left,center,right] diff --git a/src/lib/Xmobar/MinXft.hsc b/src/lib/Xmobar/MinXft.hsc deleted file mode 100644 index 0bf36c7..0000000 --- a/src/lib/Xmobar/MinXft.hsc +++ /dev/null @@ -1,333 +0,0 @@ ------------------------------------------------------------------------------- --- | --- Module: MinXft --- Copyright: (c) 2012, 2014, 2015, 2017 Jose Antonio Ortega Ruiz --- (c) Clemens Fruhwirth 2007 --- License: BSD3-style (see LICENSE) --- --- Maintainer: jao@gnu.org --- Stability: unstable --- Portability: unportable --- Created: Mon Sep 10, 2012 18:12 --- --- --- Pared down Xft library, based on Graphics.X11.Xft and providing --- explicit management of XftColors, so that they can be cached. --- --- Most of the code is lifted from Clemens's. --- ------------------------------------------------------------------------------- - -{-# LANGUAGE ForeignFunctionInterface, EmptyDataDecls #-} - -module Xmobar.MinXft ( AXftColor - , AXftDraw (..) - , AXftFont - , mallocAXftColor - , freeAXftColor - , withAXftDraw - , drawXftString - , drawXftString' - , drawBackground - , drawXftRect - , openAXftFont - , closeAXftFont - , xftTxtExtents - , xftTxtExtents' - , xft_ascent - , xft_ascent' - , xft_descent - , xft_descent' - , xft_height - , xft_height' - ) - -where - -import Graphics.X11 -import Graphics.X11.Xlib.Types -import Graphics.X11.Xrender -import Graphics.X11.Xlib.Extras (xGetWindowProperty, xFree) - -import Foreign -import Foreign.C.Types -import Foreign.C.String -import Codec.Binary.UTF8.String as UTF8 -import Data.Char (ord) - -import Control.Monad (when) - -#include - --- Color Handling - -newtype AXftColor = AXftColor (Ptr AXftColor) - -foreign import ccall "XftColorAllocName" - cXftColorAllocName :: Display -> Visual -> Colormap -> CString -> AXftColor -> IO (#type Bool) - --- this is the missing bit in X11.Xft, not implementable from the --- outside because XftColor does not export a constructor. -mallocAXftColor :: Display -> Visual -> Colormap -> String -> IO AXftColor -mallocAXftColor d v cm n = do - color <- mallocBytes (#size XftColor) - withCAString n $ \str -> cXftColorAllocName d v cm str (AXftColor color) - return (AXftColor color) - -foreign import ccall "XftColorFree" - freeAXftColor :: Display -> Visual -> Colormap -> AXftColor -> IO () - --- Font handling - -newtype AXftFont = AXftFont (Ptr AXftFont) - -xft_ascent :: AXftFont -> IO Int -xft_ascent (AXftFont p) = peekCUShort p #{offset XftFont, ascent} - -xft_ascent' :: [AXftFont] -> IO Int -xft_ascent' = (fmap maximum) . (mapM xft_ascent) - -xft_descent :: AXftFont -> IO Int -xft_descent (AXftFont p) = peekCUShort p #{offset XftFont, descent} - -xft_descent' :: [AXftFont] -> IO Int -xft_descent' = (fmap maximum) . (mapM xft_descent) - -xft_height :: AXftFont -> IO Int -xft_height (AXftFont p) = peekCUShort p #{offset XftFont, height} - -xft_height' :: [AXftFont] -> IO Int -xft_height' = (fmap maximum) . (mapM xft_height) - -foreign import ccall "XftTextExtentsUtf8" - cXftTextExtentsUtf8 :: Display -> AXftFont -> CString -> CInt -> Ptr XGlyphInfo -> IO () - -xftTxtExtents :: Display -> AXftFont -> String -> IO XGlyphInfo -xftTxtExtents d f string = - withArrayLen (map fi (UTF8.encode string)) $ - \len str_ptr -> alloca $ - \cglyph -> do - cXftTextExtentsUtf8 d f str_ptr (fi len) cglyph - peek cglyph - -xftTxtExtents' :: Display -> [AXftFont] -> String -> IO XGlyphInfo -xftTxtExtents' d fs string = do - chunks <- getChunks d fs string - let (_, _, gi, _, _) = last chunks - return gi - -foreign import ccall "XftFontOpenName" - c_xftFontOpen :: Display -> CInt -> CString -> IO AXftFont - -openAXftFont :: Display -> Screen -> String -> IO AXftFont -openAXftFont dpy screen name = - withCAString name $ - \cname -> c_xftFontOpen dpy (fi (screenNumberOfScreen screen)) cname - -foreign import ccall "XftFontClose" - closeAXftFont :: Display -> AXftFont -> IO () - -foreign import ccall "XftCharExists" - cXftCharExists :: Display -> AXftFont -> (#type FcChar32) -> IO (#type FcBool) - -xftCharExists :: Display -> AXftFont -> Char -> IO Bool -xftCharExists d f c = bool `fmap` cXftCharExists d f (fi $ ord c) - where - bool 0 = False - bool _ = True --- Drawing - -fi :: (Integral a, Num b) => a -> b -fi = fromIntegral - -newtype AXftDraw = AXftDraw (Ptr AXftDraw) - -foreign import ccall "XftDrawCreate" - c_xftDrawCreate :: Display -> Drawable -> Visual -> Colormap -> IO AXftDraw - -foreign import ccall "XftDrawDisplay" - c_xftDrawDisplay :: AXftDraw -> IO Display - -foreign import ccall "XftDrawDestroy" - c_xftDrawDestroy :: AXftDraw -> IO () - -withAXftDraw :: Display -> Drawable -> Visual -> Colormap -> (AXftDraw -> IO a) -> IO a -withAXftDraw d p v c act = do - draw <- c_xftDrawCreate d p v c - a <- act draw - c_xftDrawDestroy draw - return a - -foreign import ccall "XftDrawStringUtf8" - cXftDrawStringUtf8 :: AXftDraw -> AXftColor -> AXftFont -> CInt -> CInt -> Ptr (#type FcChar8) -> CInt -> IO () - -drawXftString :: (Integral a1, Integral a) => - AXftDraw -> AXftColor -> AXftFont -> a -> a1 -> String -> IO () -drawXftString d c f x y string = - withArrayLen (map fi (UTF8.encode string)) - (\len ptr -> cXftDrawStringUtf8 d c f (fi x) (fi y) ptr (fi len)) - -drawXftString' :: AXftDraw -> - AXftColor -> - [AXftFont] -> - Integer -> - Integer -> - String -> IO () -drawXftString' d c fs x y string = do - display <- c_xftDrawDisplay d - chunks <- getChunks display fs string - mapM_ (\(f, s, _, xo, yo) -> drawXftString d c f (x+xo) (y+yo) s) chunks - --- Split string and determine fonts/offsets for individual parts -getChunks :: Display -> [AXftFont] -> String -> - IO [(AXftFont, String, XGlyphInfo, Integer, Integer)] -getChunks disp fts str = do - chunks <- getFonts disp fts str - getOffsets (XGlyphInfo 0 0 0 0 0 0) chunks - where - -- Split string and determine fonts for individual parts - getFonts _ [] _ = return [] - getFonts _ _ [] = return [] - getFonts _ [ft] s = return [(ft, s)] - getFonts d fonts@(ft:_) s = do - -- Determine which glyph can be rendered by current font - glyphs <- mapM (xftCharExists d ft) s - -- Split string into parts that can/cannot be rendered - let splits = split (runs glyphs) s - -- Determine which font to render each chunk with - concat `fmap` mapM (getFont d fonts) splits - - -- Determine fonts for substrings - getFont _ [] _ = return [] - getFont _ [ft] (_, s) = return [(ft, s)] -- Last font, use it - getFont _ (ft:_) (True, s) = return [(ft, s)] -- Current font can render this substring - getFont d (_:fs) (False, s) = getFonts d fs s -- Fallback to next font - - -- Helpers - runs [] = [] - runs (x:xs) = let (h, t) = span (==x) xs in (x, length h + 1) : runs t - split [] _ = [] - split ((x, c):xs) s = let (h, t) = splitAt c s in (x, h) : split xs t - - -- Determine coordinates for chunks using extents - getOffsets _ [] = return [] - getOffsets (XGlyphInfo _ _ x y xo yo) ((f, s):chunks) = do - (XGlyphInfo w' h' _ _ xo' yo') <- xftTxtExtents disp f s - let gi = XGlyphInfo (xo+w') (yo+h') x y (xo+xo') (yo+yo') - rest <- getOffsets gi chunks - return $ (f, s, gi, fromIntegral xo, fromIntegral yo) : rest - -foreign import ccall "XftDrawRect" - cXftDrawRect :: AXftDraw -> AXftColor -> CInt -> CInt -> CUInt -> CUInt -> IO () - -drawXftRect :: (Integral a3, Integral a2, Integral a1, Integral a) => - AXftDraw -> AXftColor -> a -> a1 -> a2 -> a3 -> IO () -drawXftRect draw color x y width height = - cXftDrawRect draw color (fi x) (fi y) (fi width) (fi height) - -#include - -type Picture = XID -type PictOp = CInt - -data XRenderPictFormat -data XRenderPictureAttributes = XRenderPictureAttributes - --- foreign import ccall unsafe "X11/extensions/Xrender.h XRenderFillRectangle" - -- xRenderFillRectangle :: Display -> PictOp -> Picture -> Ptr XRenderColor -> CInt -> CInt -> CUInt -> CUInt -> IO () -foreign import ccall unsafe "X11/extensions/Xrender.h XRenderComposite" - xRenderComposite :: Display -> PictOp -> Picture -> Picture -> Picture -> CInt -> CInt -> CInt -> CInt -> CInt -> CInt -> CUInt -> CUInt -> IO () -foreign import ccall unsafe "X11/extensions/Xrender.h XRenderCreateSolidFill" - xRenderCreateSolidFill :: Display -> Ptr XRenderColor -> IO Picture -foreign import ccall unsafe "X11/extensions/Xrender.h XRenderFreePicture" - xRenderFreePicture :: Display -> Picture -> IO () -foreign import ccall unsafe "string.h" memset :: Ptr a -> CInt -> CSize -> IO () -foreign import ccall unsafe "X11/extensions/Xrender.h XRenderFindStandardFormat" - xRenderFindStandardFormat :: Display -> CInt -> IO (Ptr XRenderPictFormat) -foreign import ccall unsafe "X11/extensions/Xrender.h XRenderCreatePicture" - xRenderCreatePicture :: Display -> Drawable -> Ptr XRenderPictFormat -> CULong -> Ptr XRenderPictureAttributes -> IO Picture - - --- Attributes not supported -instance Storable XRenderPictureAttributes where - sizeOf _ = #{size XRenderPictureAttributes} - alignment _ = alignment (undefined :: CInt) - peek _ = return XRenderPictureAttributes - poke p XRenderPictureAttributes = - memset p 0 #{size XRenderPictureAttributes} - --- | Convenience function, gives us an XRender handle to a traditional --- Pixmap. Don't let it escape. -withRenderPicture :: Display -> Drawable -> (Picture -> IO a) -> IO () -withRenderPicture d p f = do - format <- xRenderFindStandardFormat d 1 -- PictStandardRGB24 - alloca $ \attr -> do - pic <- xRenderCreatePicture d p format 0 attr - f pic - xRenderFreePicture d pic - --- | Convenience function, gives us an XRender picture that is a solid --- fill of color 'c'. Don't let it escape. -withRenderFill :: Display -> XRenderColor -> (Picture -> IO a) -> IO () -withRenderFill d c f = do - pic <- with c (xRenderCreateSolidFill d) - f pic - xRenderFreePicture d pic - --- | Drawing the background to a pixmap and taking into account --- transparency -drawBackground :: Display -> Drawable -> String -> Int -> Rectangle -> IO () -drawBackground d p bgc alpha (Rectangle x y wid ht) = do - let render opt bg pic m = - xRenderComposite d opt bg m pic - (fromIntegral x) (fromIntegral y) 0 0 - 0 0 (fromIntegral wid) (fromIntegral ht) - withRenderPicture d p $ \pic -> do - -- Handle background color - bgcolor <- parseRenderColor d bgc - withRenderFill d bgcolor $ \bgfill -> - withRenderFill d - (XRenderColor 0 0 0 (257 * alpha)) - (render pictOpSrc bgfill pic) - -- Handle transparency - internAtom d "_XROOTPMAP_ID" False >>= \xid -> - let xroot = defaultRootWindow d in - alloca $ \x1 -> - alloca $ \x2 -> - alloca $ \x3 -> - alloca $ \x4 -> - alloca $ \pprop -> do - xGetWindowProperty d xroot xid 0 1 False 20 x1 x2 x3 x4 pprop - prop <- peek pprop - when (prop /= nullPtr) $ do - rootbg <- peek (castPtr prop) :: IO Pixmap - xFree prop - withRenderPicture d rootbg $ \bgpic -> - withRenderFill d (XRenderColor 0 0 0 (0xFFFF - 257 * alpha)) - (render pictOpAdd bgpic pic) - --- | Parses color into XRender color (allocation not necessary!) -parseRenderColor :: Display -> String -> IO XRenderColor -parseRenderColor d c = do - let colormap = defaultColormap d (defaultScreen d) - Color _ red green blue _ <- parseColor d colormap c - return $ XRenderColor (fromIntegral red) (fromIntegral green) (fromIntegral blue) 0xFFFF - -pictOpSrc, pictOpAdd :: PictOp -pictOpSrc = 1 -pictOpAdd = 12 - --- pictOpMinimum = 0 --- pictOpClear = 0 --- pictOpDst = 2 --- pictOpOver = 3 --- pictOpOverReverse = 4 --- pictOpIn = 5 --- pictOpInReverse = 6 --- pictOpOut = 7 --- pictOpOutReverse = 8 --- pictOpAtop = 9 --- pictOpAtopReverse = 10 --- pictOpXor = 11 --- pictOpSaturate = 13 --- pictOpMaximum = 13 diff --git a/src/lib/Xmobar/Types.hs b/src/lib/Xmobar/Types.hs deleted file mode 100644 index f7c4fdf..0000000 --- a/src/lib/Xmobar/Types.hs +++ /dev/null @@ -1,47 +0,0 @@ ------------------------------------------------------------------------------- --- | --- Module: Xmobar.Types --- Copyright: (c) 2018 Jose Antonio Ortega Ruiz --- License: BSD3-style (see LICENSE) --- --- Maintainer: jao@gnu.org --- Stability: unstable --- Portability: portable --- Created: Sat Nov 24, 2018 19:02 --- --- --- The Xmobar basic type --- ------------------------------------------------------------------------------- - - -module Xmobar.Types (X , XConf (..), runX) where - -import Graphics.X11.Xlib -import Control.Monad.Reader -import Data.Map - -import Xmobar.Config -import Xmobar.Bitmap -import Xmobar.XUtil - - --- The Xmobar data type and basic loops and functions. - --- | The X type is a ReaderT -type X = ReaderT XConf IO - --- | The ReaderT inner component -data XConf = - XConf { display :: Display - , rect :: Rectangle - , window :: Window - , fontListS :: [XFont] - , verticalOffsets :: [Int] - , iconS :: Map FilePath Bitmap - , config :: Config - } - --- | Runs the ReaderT -runX :: XConf -> X () -> IO () -runX xc f = runReaderT f xc diff --git a/src/lib/Xmobar/Window.hs b/src/lib/Xmobar/Window.hs deleted file mode 100644 index c8ba1bd..0000000 --- a/src/lib/Xmobar/Window.hs +++ /dev/null @@ -1,229 +0,0 @@ ------------------------------------------------------------------------------ --- | --- 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.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.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 diff --git a/src/lib/Xmobar/X11/Bitmap.hs b/src/lib/Xmobar/X11/Bitmap.hs new file mode 100644 index 0000000..7b7afeb --- /dev/null +++ b/src/lib/Xmobar/X11/Bitmap.hs @@ -0,0 +1,130 @@ +{-# LANGUAGE CPP, FlexibleContexts #-} +----------------------------------------------------------------------------- +-- | +-- Module : X11.Bitmap +-- Copyright : (C) 2013, 2015, 2017, 2018 Alexander Polakov +-- License : BSD3 +-- +-- Maintainer : jao@gnu.org +-- Stability : unstable +-- Portability : unportable +-- +----------------------------------------------------------------------------- + +module Xmobar.X11.Bitmap + ( updateCache + , drawBitmap + , Bitmap(..)) where + +import Control.Monad +import Control.Monad.Trans(MonadIO(..)) +import Data.Map hiding (map, filter) +import Graphics.X11.Xlib +import System.Directory (doesFileExist) +import System.FilePath (()) +import System.Mem.Weak ( addFinalizer ) +import Xmobar.X11.ColorCache +import Xmobar.Parsers (Widget(..)) +import Xmobar.Actions (Action) + +#ifdef XPM +import Xmobar.XPMFile(readXPMFile) +import Control.Applicative((<|>)) +#endif + +#if MIN_VERSION_mtl(2, 2, 1) +import Control.Monad.Except(MonadError(..), runExceptT) + +#else +import Control.Monad.Error(MonadError(..)) +import Control.Monad.Trans.Error(ErrorT, runErrorT) + +runExceptT :: ErrorT e m a -> m (Either e a) +runExceptT = runErrorT + +#endif + +data BitmapType = Mono Pixel | Poly + +data Bitmap = Bitmap { width :: Dimension + , height :: Dimension + , pixmap :: Pixmap + , shapePixmap :: Maybe Pixmap + , bitmapType :: BitmapType + } + +updateCache :: Display -> Window -> Map FilePath Bitmap -> FilePath -> + [[(Widget, String, Int, Maybe [Action])]] -> IO (Map FilePath Bitmap) +updateCache dpy win cache iconRoot ps = do + let paths = map (\(Icon p, _, _, _) -> p) . concatMap (filter icons) $ ps + icons (Icon _, _, _, _) = True + icons _ = False + expandPath path@('/':_) = path + expandPath path@('.':'/':_) = path + expandPath path@('.':'.':'/':_) = path + expandPath path = iconRoot path + go m path = if member path m + then return m + else do bitmap <- loadBitmap dpy win $ expandPath path + return $ maybe m (\b -> insert path b m) bitmap + foldM go cache paths + +readBitmapFile' + :: (MonadError String m, MonadIO m) + => Display + -> Drawable + -> String + -> m (Dimension, Dimension, Pixmap) +readBitmapFile' d w p = do + res <- liftIO $ readBitmapFile d w p + case res of + Left err -> throwError err + Right (bw, bh, bp, _, _) -> return (bw, bh, bp) + +loadBitmap :: Display -> Drawable -> FilePath -> IO (Maybe Bitmap) +loadBitmap d w p = do + exist <- doesFileExist p + if exist + then do +#ifdef XPM + res <- runExceptT (tryXBM <|> tryXPM) +#else + res <- runExceptT tryXBM +#endif + case res of + Right b -> return $ Just b + Left err -> do + putStrLn err + return Nothing + else + return Nothing + where tryXBM = do + (bw, bh, bp) <- readBitmapFile' d w p + liftIO $ addFinalizer bp (freePixmap d bp) + return $ Bitmap bw bh bp Nothing (Mono 1) +#ifdef XPM + tryXPM = do + (bw, bh, bp, mbpm) <- readXPMFile d w p + liftIO $ addFinalizer bp (freePixmap d bp) + case mbpm of + Nothing -> return () + Just bpm -> liftIO $ addFinalizer bpm (freePixmap d bpm) + return $ Bitmap bw bh bp mbpm Poly +#endif + +drawBitmap :: Display -> Drawable -> GC -> String -> String + -> Position -> Position -> Bitmap -> IO () +drawBitmap d p gc fc bc x y i = + withColors d [fc, bc] $ \[fc', bc'] -> do + let w = width i + h = height i + y' = 1 + y - fromIntegral h `div` 2 + setForeground d gc fc' + setBackground d gc bc' + case shapePixmap i of + Nothing -> return () + Just mask -> setClipOrigin d gc x y' >> setClipMask d gc mask + case bitmapType i of + Poly -> copyArea d (pixmap i) p gc 0 0 w h x y' + Mono pl -> copyPlane d (pixmap i) p gc 0 0 w h x y' pl + setClipMask d gc 0 diff --git a/src/lib/Xmobar/X11/ColorCache.hs b/src/lib/Xmobar/X11/ColorCache.hs new file mode 100644 index 0000000..c5e8823 --- /dev/null +++ b/src/lib/Xmobar/X11/ColorCache.hs @@ -0,0 +1,110 @@ +{-# LANGUAGE CPP #-} +------------------------------------------------------------------------------ +-- | +-- Module: ColorCache +-- Copyright: (c) 2012 Jose Antonio Ortega Ruiz +-- License: BSD3-style (see LICENSE) +-- +-- Maintainer: jao@gnu.org +-- Stability: unstable +-- Portability: unportable +-- Created: Mon Sep 10, 2012 00:27 +-- +-- +-- Caching X colors +-- +------------------------------------------------------------------------------ + +#if defined XFT + +module Xmobar.X11.ColorCache(withColors, withDrawingColors) where + +import Xmobar.X11.MinXft + +#else +module Xmobar.X11., 2018ColorCache(withColors) where + +#endif + +import Data.IORef +import System.IO.Unsafe (unsafePerformIO) +import Control.Monad.Trans (MonadIO, liftIO) +import Control.Exception (SomeException, handle) +import Graphics.X11.Xlib + +data DynPixel = DynPixel Bool Pixel + +initColor :: Display -> String -> IO DynPixel +initColor dpy c = handle black $ initColor' dpy c + where + black :: SomeException -> IO DynPixel + black = const . return $ DynPixel False (blackPixel dpy $ defaultScreen dpy) + +type ColorCache = [(String, Color)] +{-# NOINLINE colorCache #-} +colorCache :: IORef ColorCache +colorCache = unsafePerformIO $ newIORef [] + +getCachedColor :: String -> IO (Maybe Color) +getCachedColor color_name = lookup color_name `fmap` readIORef colorCache + +putCachedColor :: String -> Color -> IO () +putCachedColor name c_id = modifyIORef colorCache $ \c -> (name, c_id) : c + +initColor' :: Display -> String -> IO DynPixel +initColor' dpy c = do + let colormap = defaultColormap dpy (defaultScreen dpy) + cached_color <- getCachedColor c + c' <- case cached_color of + Just col -> return col + _ -> do (c'', _) <- allocNamedColor dpy colormap c + putCachedColor c c'' + return c'' + return $ DynPixel True (color_pixel c') + +withColors :: MonadIO m => Display -> [String] -> ([Pixel] -> m a) -> m a +withColors d cs f = do + ps <- mapM (liftIO . initColor d) cs + f $ map (\(DynPixel _ pixel) -> pixel) ps + +#ifdef XFT + +type AXftColorCache = [(String, AXftColor)] +{-# NOINLINE xftColorCache #-} +xftColorCache :: IORef AXftColorCache +xftColorCache = unsafePerformIO $ newIORef [] + +getXftCachedColor :: String -> IO (Maybe AXftColor) +getXftCachedColor name = lookup name `fmap` readIORef xftColorCache + +putXftCachedColor :: String -> AXftColor -> IO () +putXftCachedColor name cptr = + modifyIORef xftColorCache $ \c -> (name, cptr) : c + +initAXftColor' :: Display -> Visual -> Colormap -> String -> IO AXftColor +initAXftColor' d v cm c = do + cc <- getXftCachedColor c + c' <- case cc of + Just col -> return col + _ -> do c'' <- mallocAXftColor d v cm c + putXftCachedColor c c'' + return c'' + return c' + +initAXftColor :: Display -> Visual -> Colormap -> String -> IO AXftColor +initAXftColor d v cm c = handle black $ (initAXftColor' d v cm c) + where + black :: SomeException -> IO AXftColor + black = (const $ initAXftColor' d v cm "black") + +withDrawingColors :: -- MonadIO m => + Display -> Drawable -> String -> String + -> (AXftDraw -> AXftColor -> AXftColor -> IO ()) -> IO () +withDrawingColors dpy drw fc bc f = do + let screen = defaultScreenOfDisplay dpy + colormap = defaultColormapOfScreen screen + visual = defaultVisualOfScreen screen + fc' <- initAXftColor dpy visual colormap fc + bc' <- initAXftColor dpy visual colormap bc + withAXftDraw dpy drw visual colormap $ \draw -> f draw fc' bc' +#endif diff --git a/src/lib/Xmobar/X11/Draw.hs b/src/lib/Xmobar/X11/Draw.hs new file mode 100644 index 0000000..3fe6f5c --- /dev/null +++ b/src/lib/Xmobar/X11/Draw.hs @@ -0,0 +1,151 @@ +{-# LANGUAGE CPP #-} + +------------------------------------------------------------------------------ +-- | +-- Module: Xmobar.X11.Draw +-- Copyright: (c) 2018 Jose Antonio Ortega Ruiz +-- License: BSD3-style (see LICENSE) +-- +-- Maintainer: jao@gnu.org +-- Stability: unstable +-- Portability: portable +-- Created: Sat Nov 24, 2018 18:49 +-- +-- +-- Drawing the xmobar contents +-- +------------------------------------------------------------------------------ + + +module Xmobar.X11.Draw (drawInWin) where + +import Prelude hiding (lookup) +import Control.Monad.IO.Class +import Control.Monad.Reader +import Control.Monad (when) +import Control.Arrow ((&&&)) +import Data.Map hiding (foldr, map, filter) + +import Graphics.X11.Xlib hiding (textExtents, textWidth) +import Graphics.X11.Xlib.Extras + +import Xmobar.Parsers (Widget(..)) +import Xmobar.Actions (Action(..)) +import qualified Xmobar.X11.Bitmap as B +import Xmobar.X11.Types +import Xmobar.X11.XUtil +import Xmobar.Config +import Xmobar.X11.ColorCache +import Xmobar.X11.Window (drawBorder) + +#ifdef XFT +import Xmobar.X11.MinXft +import Graphics.X11.Xrender +#endif + +fi :: (Integral a, Num b) => a -> b +fi = fromIntegral + +-- | Draws in and updates the window +drawInWin :: Rectangle -> [[(Widget, String, Int, Maybe [Action])]] -> X () +drawInWin wr@(Rectangle _ _ wid ht) ~[left,center,right] = do + r <- ask + let (c,d) = (config &&& display) r + (w,(fs,vs)) = (window &&& fontListS &&& verticalOffsets) r + strLn = liftIO . mapM getWidth + iconW i = maybe 0 B.width (lookup i $ iconS r) + getWidth (Text s,cl,i,_) = + textWidth d (fs!!i) s >>= \tw -> return (Text s,cl,i,fi tw) + getWidth (Icon s,cl,i,_) = return (Icon s,cl,i,fi $ iconW s) + + p <- liftIO $ createPixmap d w wid ht + (defaultDepthOfScreen (defaultScreenOfDisplay d)) +#if XFT + when (alpha c /= 255) (liftIO $ drawBackground d p (bgColor c) (alpha c) wr) +#endif + withColors d [bgColor c, borderColor c] $ \[bgcolor, bdcolor] -> do + gc <- liftIO $ createGC d w +#if XFT + when (alpha c == 255) $ do +#else + do +#endif + liftIO $ setForeground d gc bgcolor + liftIO $ fillRectangle d p gc 0 0 wid ht + -- write to the pixmap the new string + printStrings p gc fs vs 1 L =<< strLn left + printStrings p gc fs vs 1 R =<< strLn right + printStrings p gc fs vs 1 C =<< strLn center + -- draw border if requested + liftIO $ drawBorder (border c) (borderWidth c) d p gc bdcolor wid ht + -- copy the pixmap with the new string to the window + liftIO $ copyArea d p w gc 0 0 wid ht 0 0 + -- free up everything (we do not want to leak memory!) + liftIO $ freeGC d gc + liftIO $ freePixmap d p + -- resync + liftIO $ sync d True + +verticalOffset :: (Integral b, Integral a, MonadIO m) => + a -> Widget -> XFont -> Int -> Config -> m b +verticalOffset ht (Text t) fontst voffs _ + | voffs > -1 = return $ fi voffs + | otherwise = do + (as,ds) <- liftIO $ textExtents fontst t + let margin = (fi ht - fi ds - fi as) `div` 2 + return $ fi as + margin - 1 +verticalOffset ht (Icon _) _ _ conf + | iconOffset conf > -1 = return $ fi (iconOffset conf) + | otherwise = return $ fi (ht `div` 2) - 1 + +printString :: Display -> Drawable -> XFont -> GC -> String -> String + -> Position -> Position -> String -> Int -> IO () +printString d p (Core fs) gc fc bc x y s a = do + setFont d gc $ fontFromFontStruct fs + withColors d [fc, bc] $ \[fc', bc'] -> do + setForeground d gc fc' + when (a == 255) (setBackground d gc bc') + drawImageString d p gc x y s + +printString d p (Utf8 fs) gc fc bc x y s a = + withColors d [fc, bc] $ \[fc', bc'] -> do + setForeground d gc fc' + when (a == 255) (setBackground d gc bc') + liftIO $ wcDrawImageString d p fs gc x y s + +#ifdef XFT +printString dpy drw fs@(Xft fonts) _ fc bc x y s al = + withDrawingColors dpy drw fc bc $ \draw fc' bc' -> do + when (al == 255) $ do + (a,d) <- textExtents fs s + gi <- xftTxtExtents' dpy fonts s + drawXftRect draw bc' x (y - a) (1 + xglyphinfo_xOff gi) (a + d + 2) + drawXftString' draw fc' fonts (toInteger x) (toInteger y) s +#endif + +-- | An easy way to print the stuff we need to print +printStrings :: Drawable -> GC -> [XFont] -> [Int] -> Position + -> Align -> [(Widget, String, Int, Position)] -> X () +printStrings _ _ _ _ _ _ [] = return () +printStrings dr gc fontlist voffs offs a sl@((s,c,i,l):xs) = do + r <- ask + let (conf,d) = (config &&& display) r + alph = alpha conf + Rectangle _ _ wid ht = rect r + totSLen = foldr (\(_,_,_,len) -> (+) len) 0 sl + remWidth = fi wid - fi totSLen + fontst = fontlist !! i + offset = case a of + C -> (remWidth + offs) `div` 2 + R -> remWidth + L -> offs + (fc,bc) = case break (==',') c of + (f,',':b) -> (f, b ) + (f, _) -> (f, bgColor conf) + valign <- verticalOffset ht s (head fontlist) (voffs !! i) conf + case s of + (Text t) -> liftIO $ printString d dr fontst gc fc bc offset valign t alph + (Icon p) -> liftIO $ maybe (return ()) + (B.drawBitmap d dr gc fc bc offset valign) + (lookup p (iconS r)) + printStrings dr gc fontlist voffs (offs + l) a xs diff --git a/src/lib/Xmobar/X11/EventLoop.hs b/src/lib/Xmobar/X11/EventLoop.hs new file mode 100644 index 0000000..1c864c3 --- /dev/null +++ b/src/lib/Xmobar/X11/EventLoop.hs @@ -0,0 +1,252 @@ +{-# LANGUAGE CPP #-} + +------------------------------------------------------------------------------ +-- | +-- Module: Xmobar.X11.EventLoop +-- Copyright: (c) 2018 Jose Antonio Ortega Ruiz +-- License: BSD3-style (see LICENSE) +-- +-- Maintainer: jao@gnu.org +-- Stability: unstable +-- Portability: portable +-- Created: Sat Nov 24, 2018 19:40 +-- +-- +-- Event loop +-- +------------------------------------------------------------------------------ + + +module Xmobar.X11.EventLoop (startLoop, startCommand) where + +import Prelude hiding (lookup) +import Graphics.X11.Xlib hiding (textExtents, textWidth) +import Graphics.X11.Xlib.Extras +import Graphics.X11.Xinerama +import Graphics.X11.Xrandr + +import Control.Arrow ((&&&)) +import Control.Applicative ((<$>)) +import Control.Monad.Reader +import Control.Concurrent +import Control.Concurrent.Async (Async, async) +import Control.Concurrent.STM +import Control.Exception (handle, SomeException(..)) +import Data.Bits +import Data.Map hiding (foldr, map, filter) +import Data.Maybe (fromJust, isJust) + +import Xmobar.X11.Bitmap as Bitmap +import Xmobar.X11.Types +import Xmobar.Config +import Xmobar.Parsers +import Xmobar.Commands +import Xmobar.Actions +import Xmobar.Runnable +import Xmobar.Signal +import Xmobar.X11.Window +import Xmobar.X11.XUtil +import Xmobar.Utils +import Xmobar.X11.Draw + +#ifdef XFT +import Graphics.X11.Xft +#endif + +#ifdef DBUS +import Xmobar.IPC.DBus +#endif + +runX :: XConf -> X () -> IO () +runX xc f = runReaderT f xc + +-- | Starts the main event loop and threads +startLoop :: XConf -> TMVar SignalType -> [[([Async ()], TVar String)]] + -> IO () +startLoop xcfg@(XConf _ _ w _ _ _ _) sig vs = do +#ifdef XFT + xftInitFtLibrary +#endif + tv <- atomically $ newTVar [] + _ <- forkIO (handle (handler "checker") (checker tv [] vs sig)) +#ifdef THREADED_RUNTIME + _ <- forkOS (handle (handler "eventer") (eventer sig)) +#else + _ <- forkIO (handle (handler "eventer") (eventer sig)) +#endif +#ifdef DBUS + runIPC sig +#endif + eventLoop tv xcfg [] sig + where + handler thing (SomeException e) = + void $ putStrLn ("Thread " ++ thing ++ " failed: " ++ show e) + -- Reacts on events from X + eventer signal = + allocaXEvent $ \e -> do + dpy <- openDisplay "" + xrrSelectInput dpy (defaultRootWindow dpy) rrScreenChangeNotifyMask + selectInput dpy w (exposureMask .|. structureNotifyMask .|. buttonPressMask) + + forever $ do +#ifdef THREADED_RUNTIME + nextEvent dpy e +#else + nextEvent' dpy e +#endif + ev <- getEvent e + case ev of + ConfigureEvent {} -> atomically $ putTMVar signal Reposition + ExposeEvent {} -> atomically $ putTMVar signal Wakeup + RRScreenChangeNotifyEvent {} -> atomically $ putTMVar signal Reposition + ButtonEvent {} -> atomically $ putTMVar signal (Action (ev_button ev) (fi $ ev_x ev)) + _ -> return () + +-- | Send signal to eventLoop every time a var is updated +checker :: TVar [String] + -> [String] + -> [[([Async ()], TVar String)]] + -> TMVar SignalType + -> IO () +checker tvar ov vs signal = do + nval <- atomically $ do + nv <- mapM concatV vs + guard (nv /= ov) + writeTVar tvar nv + return nv + atomically $ putTMVar signal Wakeup + checker tvar nval vs signal + where + concatV = fmap concat . mapM (readTVar . snd) + + +-- | Continuously wait for a signal from a thread or a interrupt handler +eventLoop :: TVar [String] + -> XConf + -> [([Action], Position, Position)] + -> TMVar SignalType + -> IO () +eventLoop tv xc@(XConf d r w fs vos is cfg) as signal = do + typ <- atomically $ takeTMVar signal + case typ of + Wakeup -> do + str <- updateString cfg tv + xc' <- updateCache d w is (iconRoot cfg) str >>= + \c -> return xc { iconS = c } + as' <- updateActions xc r str + runX xc' $ drawInWin r str + eventLoop tv xc' as' signal + + Reposition -> + reposWindow cfg + + ChangeScreen -> do + ncfg <- updateConfigPosition cfg + reposWindow ncfg + + Hide t -> hide (t*100*1000) + Reveal t -> reveal (t*100*1000) + Toggle t -> toggle t + + TogglePersistent -> eventLoop + tv xc { config = cfg { persistent = not $ persistent cfg } } as signal + + Action but x -> action but x + + where + isPersistent = not $ persistent cfg + + hide t + | t == 0 = + when isPersistent (hideWindow d w) >> eventLoop tv xc as signal + | otherwise = do + void $ forkIO + $ threadDelay t >> atomically (putTMVar signal $ Hide 0) + eventLoop tv xc as signal + + reveal t + | t == 0 = do + when isPersistent (showWindow r cfg d w) + eventLoop tv xc as signal + | otherwise = do + void $ forkIO + $ threadDelay t >> atomically (putTMVar signal $ Reveal 0) + eventLoop tv xc as signal + + toggle t = do + ismapped <- isMapped d w + atomically (putTMVar signal $ if ismapped then Hide t else Reveal t) + eventLoop tv xc as signal + + reposWindow rcfg = do + r' <- repositionWin d w (head fs) rcfg + eventLoop tv (XConf d r' w fs vos is rcfg) as signal + + updateConfigPosition ocfg = + case position ocfg of + OnScreen n o -> do + srs <- getScreenInfo d + return (if n == length srs + then + (ocfg {position = OnScreen 1 o}) + else + (ocfg {position = OnScreen (n+1) o})) + o -> return (ocfg {position = OnScreen 1 o}) + + action button x = do + mapM_ runAction $ + filter (\(Spawn b _) -> button `elem` b) $ + concatMap (\(a,_,_) -> a) $ + filter (\(_, from, to) -> x >= from && x <= to) as + eventLoop tv xc as signal + +-- $command + +-- | Runs a command as an independent thread and returns its Async handles +-- and the TVar the command will be writing to. +startCommand :: TMVar SignalType + -> (Runnable,String,String) + -> IO ([Async ()], TVar String) +startCommand sig (com,s,ss) + | alias com == "" = do var <- atomically $ newTVar is + atomically $ writeTVar var (s ++ ss) + return ([], var) + | otherwise = do var <- atomically $ newTVar is + let cb str = atomically $ writeTVar var (s ++ str ++ ss) + a1 <- async $ start com cb + a2 <- async $ trigger com $ maybe (return ()) + (atomically . putTMVar sig) + return ([a1, a2], var) + where is = s ++ "Updating..." ++ ss + +updateString :: Config -> TVar [String] + -> IO [[(Widget, String, Int, Maybe [Action])]] +updateString conf v = do + s <- readTVarIO v + let l:c:r:_ = s ++ repeat "" + liftIO $ mapM (parseString conf) [l, c, r] + +updateActions :: XConf -> Rectangle -> [[(Widget, String, Int, Maybe [Action])]] + -> IO [([Action], Position, Position)] +updateActions conf (Rectangle _ _ wid _) ~[left,center,right] = do + let (d,fs) = (display &&& fontListS) conf + strLn :: [(Widget, String, Int, Maybe [Action])] -> IO [(Maybe [Action], Position, Position)] + strLn = liftIO . mapM getCoords + iconW i = maybe 0 Bitmap.width (lookup i $ iconS conf) + getCoords (Text s,_,i,a) = textWidth d (fs!!i) s >>= \tw -> return (a, 0, fi tw) + getCoords (Icon s,_,_,a) = return (a, 0, fi $ iconW s) + partCoord off xs = map (\(a, x, x') -> (fromJust a, x, x')) $ + filter (\(a, _,_) -> isJust a) $ + scanl (\(_,_,x') (a,_,w') -> (a, x', x' + w')) + (Nothing, 0, off) + xs + totSLen = foldr (\(_,_,len) -> (+) len) 0 + remWidth xs = fi wid - totSLen xs + offs = 1 + offset a xs = case a of + C -> (remWidth xs + offs) `div` 2 + R -> remWidth xs + L -> offs + fmap concat $ mapM (\(a,xs) -> + (\xs' -> partCoord (offset a xs') xs') <$> strLn xs) $ + zip [L,C,R] [left,center,right] diff --git a/src/lib/Xmobar/X11/MinXft.hsc b/src/lib/Xmobar/X11/MinXft.hsc new file mode 100644 index 0000000..e593da0 --- /dev/null +++ b/src/lib/Xmobar/X11/MinXft.hsc @@ -0,0 +1,333 @@ +------------------------------------------------------------------------------ +-- | +-- Module: MinXft +-- Copyright: (c) 2012, 2014, 2015, 2017 Jose Antonio Ortega Ruiz +-- (c) Clemens Fruhwirth 2007 +-- License: BSD3-style (see LICENSE) +-- +-- Maintainer: jao@gnu.org +-- Stability: unstable +-- Portability: unportable +-- Created: Mon Sep 10, 2012 18:12 +-- +-- +-- Pared down Xft library, based on Graphics.X11.Xft and providing +-- explicit management of XftColors, so that they can be cached. +-- +-- Most of the code is lifted from Clemens's. +-- +------------------------------------------------------------------------------ + +{-# LANGUAGE ForeignFunctionInterface, EmptyDataDecls #-} + +module Xmobar.X11.MinXft ( AXftColor + , AXftDraw (..) + , AXftFont + , mallocAXftColor + , freeAXftColor + , withAXftDraw + , drawXftString + , drawXftString' + , drawBackground + , drawXftRect + , openAXftFont + , closeAXftFont + , xftTxtExtents + , xftTxtExtents' + , xft_ascent + , xft_ascent' + , xft_descent + , xft_descent' + , xft_height + , xft_height' + ) + +where + +import Graphics.X11 +import Graphics.X11.Xlib.Types +import Graphics.X11.Xrender +import Graphics.X11.Xlib.Extras (xGetWindowProperty, xFree) + +import Foreign +import Foreign.C.Types +import Foreign.C.String +import Codec.Binary.UTF8.String as UTF8 +import Data.Char (ord) + +import Control.Monad (when) + +#include + +-- Color Handling + +newtype AXftColor = AXftColor (Ptr AXftColor) + +foreign import ccall "XftColorAllocName" + cXftColorAllocName :: Display -> Visual -> Colormap -> CString -> AXftColor -> IO (#type Bool) + +-- this is the missing bit in X11.Xft, not implementable from the +-- outside because XftColor does not export a constructor. +mallocAXftColor :: Display -> Visual -> Colormap -> String -> IO AXftColor +mallocAXftColor d v cm n = do + color <- mallocBytes (#size XftColor) + withCAString n $ \str -> cXftColorAllocName d v cm str (AXftColor color) + return (AXftColor color) + +foreign import ccall "XftColorFree" + freeAXftColor :: Display -> Visual -> Colormap -> AXftColor -> IO () + +-- Font handling + +newtype AXftFont = AXftFont (Ptr AXftFont) + +xft_ascent :: AXftFont -> IO Int +xft_ascent (AXftFont p) = peekCUShort p #{offset XftFont, ascent} + +xft_ascent' :: [AXftFont] -> IO Int +xft_ascent' = (fmap maximum) . (mapM xft_ascent) + +xft_descent :: AXftFont -> IO Int +xft_descent (AXftFont p) = peekCUShort p #{offset XftFont, descent} + +xft_descent' :: [AXftFont] -> IO Int +xft_descent' = (fmap maximum) . (mapM xft_descent) + +xft_height :: AXftFont -> IO Int +xft_height (AXftFont p) = peekCUShort p #{offset XftFont, height} + +xft_height' :: [AXftFont] -> IO Int +xft_height' = (fmap maximum) . (mapM xft_height) + +foreign import ccall "XftTextExtentsUtf8" + cXftTextExtentsUtf8 :: Display -> AXftFont -> CString -> CInt -> Ptr XGlyphInfo -> IO () + +xftTxtExtents :: Display -> AXftFont -> String -> IO XGlyphInfo +xftTxtExtents d f string = + withArrayLen (map fi (UTF8.encode string)) $ + \len str_ptr -> alloca $ + \cglyph -> do + cXftTextExtentsUtf8 d f str_ptr (fi len) cglyph + peek cglyph + +xftTxtExtents' :: Display -> [AXftFont] -> String -> IO XGlyphInfo +xftTxtExtents' d fs string = do + chunks <- getChunks d fs string + let (_, _, gi, _, _) = last chunks + return gi + +foreign import ccall "XftFontOpenName" + c_xftFontOpen :: Display -> CInt -> CString -> IO AXftFont + +openAXftFont :: Display -> Screen -> String -> IO AXftFont +openAXftFont dpy screen name = + withCAString name $ + \cname -> c_xftFontOpen dpy (fi (screenNumberOfScreen screen)) cname + +foreign import ccall "XftFontClose" + closeAXftFont :: Display -> AXftFont -> IO () + +foreign import ccall "XftCharExists" + cXftCharExists :: Display -> AXftFont -> (#type FcChar32) -> IO (#type FcBool) + +xftCharExists :: Display -> AXftFont -> Char -> IO Bool +xftCharExists d f c = bool `fmap` cXftCharExists d f (fi $ ord c) + where + bool 0 = False + bool _ = True +-- Drawing + +fi :: (Integral a, Num b) => a -> b +fi = fromIntegral + +newtype AXftDraw = AXftDraw (Ptr AXftDraw) + +foreign import ccall "XftDrawCreate" + c_xftDrawCreate :: Display -> Drawable -> Visual -> Colormap -> IO AXftDraw + +foreign import ccall "XftDrawDisplay" + c_xftDrawDisplay :: AXftDraw -> IO Display + +foreign import ccall "XftDrawDestroy" + c_xftDrawDestroy :: AXftDraw -> IO () + +withAXftDraw :: Display -> Drawable -> Visual -> Colormap -> (AXftDraw -> IO a) -> IO a +withAXftDraw d p v c act = do + draw <- c_xftDrawCreate d p v c + a <- act draw + c_xftDrawDestroy draw + return a + +foreign import ccall "XftDrawStringUtf8" + cXftDrawStringUtf8 :: AXftDraw -> AXftColor -> AXftFont -> CInt -> CInt -> Ptr (#type FcChar8) -> CInt -> IO () + +drawXftString :: (Integral a1, Integral a) => + AXftDraw -> AXftColor -> AXftFont -> a -> a1 -> String -> IO () +drawXftString d c f x y string = + withArrayLen (map fi (UTF8.encode string)) + (\len ptr -> cXftDrawStringUtf8 d c f (fi x) (fi y) ptr (fi len)) + +drawXftString' :: AXftDraw -> + AXftColor -> + [AXftFont] -> + Integer -> + Integer -> + String -> IO () +drawXftString' d c fs x y string = do + display <- c_xftDrawDisplay d + chunks <- getChunks display fs string + mapM_ (\(f, s, _, xo, yo) -> drawXftString d c f (x+xo) (y+yo) s) chunks + +-- Split string and determine fonts/offsets for individual parts +getChunks :: Display -> [AXftFont] -> String -> + IO [(AXftFont, String, XGlyphInfo, Integer, Integer)] +getChunks disp fts str = do + chunks <- getFonts disp fts str + getOffsets (XGlyphInfo 0 0 0 0 0 0) chunks + where + -- Split string and determine fonts for individual parts + getFonts _ [] _ = return [] + getFonts _ _ [] = return [] + getFonts _ [ft] s = return [(ft, s)] + getFonts d fonts@(ft:_) s = do + -- Determine which glyph can be rendered by current font + glyphs <- mapM (xftCharExists d ft) s + -- Split string into parts that can/cannot be rendered + let splits = split (runs glyphs) s + -- Determine which font to render each chunk with + concat `fmap` mapM (getFont d fonts) splits + + -- Determine fonts for substrings + getFont _ [] _ = return [] + getFont _ [ft] (_, s) = return [(ft, s)] -- Last font, use it + getFont _ (ft:_) (True, s) = return [(ft, s)] -- Current font can render this substring + getFont d (_:fs) (False, s) = getFonts d fs s -- Fallback to next font + + -- Helpers + runs [] = [] + runs (x:xs) = let (h, t) = span (==x) xs in (x, length h + 1) : runs t + split [] _ = [] + split ((x, c):xs) s = let (h, t) = splitAt c s in (x, h) : split xs t + + -- Determine coordinates for chunks using extents + getOffsets _ [] = return [] + getOffsets (XGlyphInfo _ _ x y xo yo) ((f, s):chunks) = do + (XGlyphInfo w' h' _ _ xo' yo') <- xftTxtExtents disp f s + let gi = XGlyphInfo (xo+w') (yo+h') x y (xo+xo') (yo+yo') + rest <- getOffsets gi chunks + return $ (f, s, gi, fromIntegral xo, fromIntegral yo) : rest + +foreign import ccall "XftDrawRect" + cXftDrawRect :: AXftDraw -> AXftColor -> CInt -> CInt -> CUInt -> CUInt -> IO () + +drawXftRect :: (Integral a3, Integral a2, Integral a1, Integral a) => + AXftDraw -> AXftColor -> a -> a1 -> a2 -> a3 -> IO () +drawXftRect draw color x y width height = + cXftDrawRect draw color (fi x) (fi y) (fi width) (fi height) + +#include + +type Picture = XID +type PictOp = CInt + +data XRenderPictFormat +data XRenderPictureAttributes = XRenderPictureAttributes + +-- foreign import ccall unsafe "X11/extensions/Xrender.h XRenderFillRectangle" + -- xRenderFillRectangle :: Display -> PictOp -> Picture -> Ptr XRenderColor -> CInt -> CInt -> CUInt -> CUInt -> IO () +foreign import ccall unsafe "X11/extensions/Xrender.h XRenderComposite" + xRenderComposite :: Display -> PictOp -> Picture -> Picture -> Picture -> CInt -> CInt -> CInt -> CInt -> CInt -> CInt -> CUInt -> CUInt -> IO () +foreign import ccall unsafe "X11/extensions/Xrender.h XRenderCreateSolidFill" + xRenderCreateSolidFill :: Display -> Ptr XRenderColor -> IO Picture +foreign import ccall unsafe "X11/extensions/Xrender.h XRenderFreePicture" + xRenderFreePicture :: Display -> Picture -> IO () +foreign import ccall unsafe "string.h" memset :: Ptr a -> CInt -> CSize -> IO () +foreign import ccall unsafe "X11/extensions/Xrender.h XRenderFindStandardFormat" + xRenderFindStandardFormat :: Display -> CInt -> IO (Ptr XRenderPictFormat) +foreign import ccall unsafe "X11/extensions/Xrender.h XRenderCreatePicture" + xRenderCreatePicture :: Display -> Drawable -> Ptr XRenderPictFormat -> CULong -> Ptr XRenderPictureAttributes -> IO Picture + + +-- Attributes not supported +instance Storable XRenderPictureAttributes where + sizeOf _ = #{size XRenderPictureAttributes} + alignment _ = alignment (undefined :: CInt) + peek _ = return XRenderPictureAttributes + poke p XRenderPictureAttributes = + memset p 0 #{size XRenderPictureAttributes} + +-- | Convenience function, gives us an XRender handle to a traditional +-- Pixmap. Don't let it escape. +withRenderPicture :: Display -> Drawable -> (Picture -> IO a) -> IO () +withRenderPicture d p f = do + format <- xRenderFindStandardFormat d 1 -- PictStandardRGB24 + alloca $ \attr -> do + pic <- xRenderCreatePicture d p format 0 attr + f pic + xRenderFreePicture d pic + +-- | Convenience function, gives us an XRender picture that is a solid +-- fill of color 'c'. Don't let it escape. +withRenderFill :: Display -> XRenderColor -> (Picture -> IO a) -> IO () +withRenderFill d c f = do + pic <- with c (xRenderCreateSolidFill d) + f pic + xRenderFreePicture d pic + +-- | Drawing the background to a pixmap and taking into account +-- transparency +drawBackground :: Display -> Drawable -> String -> Int -> Rectangle -> IO () +drawBackground d p bgc alpha (Rectangle x y wid ht) = do + let render opt bg pic m = + xRenderComposite d opt bg m pic + (fromIntegral x) (fromIntegral y) 0 0 + 0 0 (fromIntegral wid) (fromIntegral ht) + withRenderPicture d p $ \pic -> do + -- Handle background color + bgcolor <- parseRenderColor d bgc + withRenderFill d bgcolor $ \bgfill -> + withRenderFill d + (XRenderColor 0 0 0 (257 * alpha)) + (render pictOpSrc bgfill pic) + -- Handle transparency + internAtom d "_XROOTPMAP_ID" False >>= \xid -> + let xroot = defaultRootWindow d in + alloca $ \x1 -> + alloca $ \x2 -> + alloca $ \x3 -> + alloca $ \x4 -> + alloca $ \pprop -> do + xGetWindowProperty d xroot xid 0 1 False 20 x1 x2 x3 x4 pprop + prop <- peek pprop + when (prop /= nullPtr) $ do + rootbg <- peek (castPtr prop) :: IO Pixmap + xFree prop + withRenderPicture d rootbg $ \bgpic -> + withRenderFill d (XRenderColor 0 0 0 (0xFFFF - 257 * alpha)) + (render pictOpAdd bgpic pic) + +-- | Parses color into XRender color (allocation not necessary!) +parseRenderColor :: Display -> String -> IO XRenderColor +parseRenderColor d c = do + let colormap = defaultColormap d (defaultScreen d) + Color _ red green blue _ <- parseColor d colormap c + return $ XRenderColor (fromIntegral red) (fromIntegral green) (fromIntegral blue) 0xFFFF + +pictOpSrc, pictOpAdd :: PictOp +pictOpSrc = 1 +pictOpAdd = 12 + +-- pictOpMinimum = 0 +-- pictOpClear = 0 +-- pictOpDst = 2 +-- pictOpOver = 3 +-- pictOpOverReverse = 4 +-- pictOpIn = 5 +-- pictOpInReverse = 6 +-- pictOpOut = 7 +-- pictOpOutReverse = 8 +-- pictOpAtop = 9 +-- pictOpAtopReverse = 10 +-- pictOpXor = 11 +-- pictOpSaturate = 13 +-- pictOpMaximum = 13 diff --git a/src/lib/Xmobar/X11/Types.hs b/src/lib/Xmobar/X11/Types.hs new file mode 100644 index 0000000..77249b3 --- /dev/null +++ b/src/lib/Xmobar/X11/Types.hs @@ -0,0 +1,40 @@ +------------------------------------------------------------------------------ +-- | +-- Module: Xmobar.Types +-- Copyright: (c) 2018 Jose Antonio Ortega Ruiz +-- License: BSD3-style (see LICENSE) +-- +-- Maintainer: jao@gnu.org +-- Stability: unstable +-- Portability: portable +-- Created: Sat Nov 24, 2018 19:02 +-- +-- +-- The Xmobar basic type +-- +------------------------------------------------------------------------------ + + +module Xmobar.X11.Types (X , XConf (..)) where + +import Graphics.X11.Xlib +import Control.Monad.Reader +import Data.Map + +import Xmobar.X11.Bitmap +import Xmobar.X11.XUtil +import Xmobar.Config + +-- | The X type is a ReaderT +type X = ReaderT XConf IO + +-- | The ReaderT inner component +data XConf = + XConf { display :: Display + , rect :: Rectangle + , window :: Window + , fontListS :: [XFont] + , verticalOffsets :: [Int] + , iconS :: Map FilePath Bitmap + , config :: Config + } diff --git a/src/lib/Xmobar/X11/Window.hs b/src/lib/Xmobar/X11/Window.hs new file mode 100644 index 0000000..78f4b26 --- /dev/null +++ b/src/lib/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 diff --git a/src/lib/Xmobar/X11/XUtil.hs b/src/lib/Xmobar/X11/XUtil.hs new file mode 100644 index 0000000..6e9eb2b --- /dev/null +++ b/src/lib/Xmobar/X11/XUtil.hs @@ -0,0 +1,129 @@ +{-# LANGUAGE CPP #-} + +----------------------------------------------------------------------------- +-- | +-- Module : XUtil +-- Copyright : (C) 2011, 2012, 2013, 2014, 2015, 2017, 2018 Jose Antonio Ortega Ruiz +-- (C) 2007 Andrea Rossato +-- License : BSD3 +-- +-- Maintainer : jao@gnu.org +-- Stability : unstable +-- Portability : unportable +-- +----------------------------------------------------------------------------- + +module Xmobar.X11.XUtil + ( XFont(..) + , initFont + , initCoreFont + , initUtf8Font + , textExtents + , textWidth + ) where + +import Control.Exception (SomeException, handle) +import Data.List +import Foreign +import Graphics.X11.Xlib hiding (textExtents, textWidth) +import qualified Graphics.X11.Xlib as Xlib (textExtents, textWidth) +import Graphics.X11.Xlib.Extras +import System.Mem.Weak ( addFinalizer ) + +#if defined XFT +import Xmobar.X11.MinXft +import Graphics.X11.Xrender +#else +import System.IO(hPutStrLn, stderr) +#endif + +data XFont = Core FontStruct + | Utf8 FontSet +#ifdef XFT + | Xft [AXftFont] +#endif + +-- | When initFont gets a font name that starts with 'xft:' it switchs +-- to the Xft backend Example: 'xft:Sans-10' +initFont :: Display -> String -> IO XFont +initFont d s = + let xftPrefix = "xft:" in + if xftPrefix `isPrefixOf` s then +#ifdef XFT + fmap Xft $ initXftFont d s +#else + do + hPutStrLn stderr $ "Warning: Xmobar must be built with " + ++ "the with_xft flag to support font '" ++ s + ++ ".' Falling back on default." + initFont d miscFixedFont +#endif + else + fmap Utf8 $ initUtf8Font d s + +miscFixedFont :: String +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. +initCoreFont :: Display -> String -> IO FontStruct +initCoreFont d s = do + f <- handle fallBack getIt + addFinalizer f (freeFont d f) + return f + where getIt = loadQueryFont d s + fallBack :: SomeException -> IO FontStruct + fallBack = const $ loadQueryFont d miscFixedFont + +-- | 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 d s = do + (_,_,f) <- handle fallBack getIt + addFinalizer f (freeFontSet d f) + return f + where getIt = createFontSet d s + fallBack :: SomeException -> IO ([String], String, FontSet) + fallBack = const $ createFontSet d miscFixedFont + +#ifdef XFT +initXftFont :: Display -> String -> IO [AXftFont] +initXftFont d s = do + let fontNames = wordsBy (== ',') (drop 4 s) + mapM openFont fontNames + where + openFont fontName = do + f <- openAXftFont d (defaultScreenOfDisplay d) fontName + addFinalizer f (closeAXftFont d f) + return f + wordsBy p str = case dropWhile p str of + "" -> [] + str' -> w : wordsBy p str'' + where + (w, str'') = break p str' +#endif + +textWidth :: Display -> XFont -> String -> IO Int +textWidth _ (Utf8 fs) s = return $ fromIntegral $ wcTextEscapement fs s +textWidth _ (Core fs) s = return $ fromIntegral $ Xlib.textWidth fs s +#ifdef XFT +textWidth dpy (Xft xftdraw) s = do + gi <- xftTxtExtents' dpy xftdraw s + return $ xglyphinfo_xOff gi +#endif + +textExtents :: XFont -> String -> IO (Int32,Int32) +textExtents (Core fs) s = do + let (_,a,d,_) = Xlib.textExtents fs s + return (a,d) +textExtents (Utf8 fs) s = do + let (_,rl) = wcTextExtents fs s + ascent = fromIntegral $ - (rect_y rl) + descent = fromIntegral $ rect_height rl + fromIntegral (rect_y rl) + return (ascent, descent) +#ifdef XFT +textExtents (Xft xftfonts) _ = do + ascent <- fromIntegral `fmap` xft_ascent' xftfonts + descent <- fromIntegral `fmap` xft_descent' xftfonts + return (ascent, descent) +#endif diff --git a/src/lib/Xmobar/XUtil.hs b/src/lib/Xmobar/XUtil.hs deleted file mode 100644 index e70612b..0000000 --- a/src/lib/Xmobar/XUtil.hs +++ /dev/null @@ -1,160 +0,0 @@ -{-# LANGUAGE CPP #-} - ------------------------------------------------------------------------------ --- | --- Module : XUtil --- Copyright : (C) 2011, 2012, 2013, 2014, 2015, 2017, 2018 Jose Antonio Ortega Ruiz --- (C) 2007 Andrea Rossato --- License : BSD3 --- --- Maintainer : jao@gnu.org --- Stability : unstable --- Portability : unportable --- ------------------------------------------------------------------------------ - -module Xmobar.XUtil - ( XFont - , initFont - , initCoreFont - , initUtf8Font - , textExtents - , textWidth - , printString - ) where - -import Control.Monad (when) -import Control.Monad.Trans -import Control.Exception (SomeException, handle) -import Data.List -import Foreign -import Graphics.X11.Xlib hiding (textExtents, textWidth) -import qualified Graphics.X11.Xlib as Xlib (textExtents, textWidth) -import Graphics.X11.Xlib.Extras -import System.Mem.Weak ( addFinalizer ) - -#if defined XFT -import Xmobar.MinXft -import Graphics.X11.Xrender -#else -import System.IO(hPutStrLn, stderr) -#endif - -import Xmobar.ColorCache - --- Hide the Core Font/Xft switching here -data XFont = Core FontStruct - | Utf8 FontSet -#ifdef XFT - | Xft [AXftFont] -#endif - --- | When initFont gets a font name that starts with 'xft:' it switchs --- to the Xft backend Example: 'xft:Sans-10' -initFont :: Display -> String -> IO XFont -initFont d s = - let xftPrefix = "xft:" in - if xftPrefix `isPrefixOf` s then -#ifdef XFT - fmap Xft $ initXftFont d s -#else - do - hPutStrLn stderr $ "Warning: Xmobar must be built with " - ++ "the with_xft flag to support font '" ++ s - ++ ".' Falling back on default." - initFont d miscFixedFont -#endif - else - fmap Utf8 $ initUtf8Font d s - -miscFixedFont :: String -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. -initCoreFont :: Display -> String -> IO FontStruct -initCoreFont d s = do - f <- handle fallBack getIt - addFinalizer f (freeFont d f) - return f - where getIt = loadQueryFont d s - fallBack :: SomeException -> IO FontStruct - fallBack = const $ loadQueryFont d miscFixedFont - --- | 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 d s = do - (_,_,f) <- handle fallBack getIt - addFinalizer f (freeFontSet d f) - return f - where getIt = createFontSet d s - fallBack :: SomeException -> IO ([String], String, FontSet) - fallBack = const $ createFontSet d miscFixedFont - -#ifdef XFT -initXftFont :: Display -> String -> IO [AXftFont] -initXftFont d s = do - let fontNames = wordsBy (== ',') (drop 4 s) - mapM openFont fontNames - where - openFont fontName = do - f <- openAXftFont d (defaultScreenOfDisplay d) fontName - addFinalizer f (closeAXftFont d f) - return f - wordsBy p str = case dropWhile p str of - "" -> [] - str' -> w : wordsBy p str'' - where - (w, str'') = break p str' -#endif - -textWidth :: Display -> XFont -> String -> IO Int -textWidth _ (Utf8 fs) s = return $ fromIntegral $ wcTextEscapement fs s -textWidth _ (Core fs) s = return $ fromIntegral $ Xlib.textWidth fs s -#ifdef XFT -textWidth dpy (Xft xftdraw) s = do - gi <- xftTxtExtents' dpy xftdraw s - return $ xglyphinfo_xOff gi -#endif - -textExtents :: XFont -> String -> IO (Int32,Int32) -textExtents (Core fs) s = do - let (_,a,d,_) = Xlib.textExtents fs s - return (a,d) -textExtents (Utf8 fs) s = do - let (_,rl) = wcTextExtents fs s - ascent = fromIntegral $ - (rect_y rl) - descent = fromIntegral $ rect_height rl + fromIntegral (rect_y rl) - return (ascent, descent) -#ifdef XFT -textExtents (Xft xftfonts) _ = do - ascent <- fromIntegral `fmap` xft_ascent' xftfonts - descent <- fromIntegral `fmap` xft_descent' xftfonts - return (ascent, descent) -#endif - -printString :: Display -> Drawable -> XFont -> GC -> String -> String - -> Position -> Position -> String -> Int -> IO () -printString d p (Core fs) gc fc bc x y s a = do - setFont d gc $ fontFromFontStruct fs - withColors d [fc, bc] $ \[fc', bc'] -> do - setForeground d gc fc' - when (a == 255) (setBackground d gc bc') - drawImageString d p gc x y s - -printString d p (Utf8 fs) gc fc bc x y s a = - withColors d [fc, bc] $ \[fc', bc'] -> do - setForeground d gc fc' - when (a == 255) (setBackground d gc bc') - liftIO $ wcDrawImageString d p fs gc x y s - -#ifdef XFT -printString dpy drw fs@(Xft fonts) _ fc bc x y s al = - withDrawingColors dpy drw fc bc $ \draw fc' bc' -> do - when (al == 255) $ do - (a,d) <- textExtents fs s - gi <- xftTxtExtents' dpy fonts s - drawXftRect draw bc' x (y - a) (1 + xglyphinfo_xOff gi) (a + d + 2) - drawXftString' draw fc' fonts (toInteger x) (toInteger y) s -#endif diff --git a/xmobar.cabal b/xmobar.cabal index efe5a5d..dfa75a8 100644 --- a/xmobar.cabal +++ b/xmobar.cabal @@ -95,10 +95,8 @@ library hs-source-dirs: src/lib exposed-modules: Xmobar, - Xmobar.Types, Xmobar.Config, Xmobar.Actions, - Xmobar.Bitmap, Xmobar.Commands, Xmobar.Runnable, Xmobar.Plugins, @@ -134,14 +132,16 @@ library other-modules: Xmobar.Localize, Xmobar.Parsers, Xmobar.Utils, - Xmobar.XUtil, Xmobar.StatFS, - Xmobar.ColorCache, - Xmobar.Window, - Xmobar.Draw, + Xmobar.X11.Types, + Xmobar.X11.XUtil, + Xmobar.X11.Bitmap, + Xmobar.X11.EventLoop, + Xmobar.X11.ColorCache, + Xmobar.X11.Window, + Xmobar.X11.Draw, Xmobar.Signal, - Xmobar.Environment, - Xmobar.EventLoop + Xmobar.Environment extra-libraries: Xrandr Xrender @@ -181,7 +181,7 @@ library if flag(with_xft) || flag(all_extensions) build-depends: utf8-string >= 0.3 && < 1.1, X11-xft >= 0.2 && < 0.4 - other-modules: Xmobar.MinXft + other-modules: Xmobar.X11.MinXft cpp-options: -DXFT if flag(with_utf8) || flag(all_extensions) @@ -298,20 +298,18 @@ test-suite XmobarTest hspec == 2.*, xmobar - other-modules: Plugins.Monitors.CommonSpec, - Xmobar.Commands, - Xmobar.Signal, - Xmobar.XUtil, - Xmobar.Utils, - Xmobar.ColorCache, - Xmobar.Plugins, - Xmobar.Plugins.Monitors.Common + other-modules: Plugins.Monitors.CommonSpec if flag(with_alsa) || flag(all_extensions) - build-depends: alsa-mixer > 0.2.0.2 - build-depends: alsa-core == 0.5.*, + build-depends: alsa-mixer > 0.2.0.2, + alsa-core == 0.5.*, process >= 1.4.3.0 - other-modules: Xmobar.Plugins.Monitors.Volume, - Xmobar.Plugins.Monitors.Alsa, + other-modules: Xmobar.Plugins.Monitors.Volume + Xmobar.Plugins.Monitors.Alsa Plugins.Monitors.AlsaSpec + Xmobar.Commands + Xmobar.Plugins + Xmobar.Plugins.Monitors.Common + Xmobar.Signal + Xmobar.Utils cpp-options: -DALSA -- cgit v1.2.3