diff options
Diffstat (limited to 'src/lib/Xmobar/X11')
| -rw-r--r-- | src/lib/Xmobar/X11/Bitmap.hs | 130 | ||||
| -rw-r--r-- | src/lib/Xmobar/X11/ColorCache.hs | 111 | ||||
| -rw-r--r-- | src/lib/Xmobar/X11/Draw.hs | 151 | ||||
| -rw-r--r-- | src/lib/Xmobar/X11/MinXft.hsc | 333 | ||||
| -rw-r--r-- | src/lib/Xmobar/X11/Parsers.hs | 146 | ||||
| -rw-r--r-- | src/lib/Xmobar/X11/Types.hs | 40 | ||||
| -rw-r--r-- | src/lib/Xmobar/X11/Window.hs | 229 | ||||
| -rw-r--r-- | src/lib/Xmobar/X11/XPMFile.hsc | 60 | ||||
| -rw-r--r-- | src/lib/Xmobar/X11/XUtil.hs | 129 |
9 files changed, 0 insertions, 1329 deletions
diff --git a/src/lib/Xmobar/X11/Bitmap.hs b/src/lib/Xmobar/X11/Bitmap.hs deleted file mode 100644 index c0dba14..0000000 --- a/src/lib/Xmobar/X11/Bitmap.hs +++ /dev/null @@ -1,130 +0,0 @@ -{-# 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.X11.Parsers (Widget(..)) -import Xmobar.Actions (Action) - -#ifdef XPM -import Xmobar.X11.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 deleted file mode 100644 index 4d22e16..0000000 --- a/src/lib/Xmobar/X11/ColorCache.hs +++ /dev/null @@ -1,111 +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.X11.ColorCache(withColors, withDrawingColors) where - -import Xmobar.X11.MinXft - -#else - -module Xmobar.X11.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/X11/Draw.hs b/src/lib/Xmobar/X11/Draw.hs deleted file mode 100644 index d0c78a8..0000000 --- a/src/lib/Xmobar/X11/Draw.hs +++ /dev/null @@ -1,151 +0,0 @@ -{-# 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.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) -import Xmobar.X11.Parsers (Widget(..)) - -#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/MinXft.hsc b/src/lib/Xmobar/X11/MinXft.hsc deleted file mode 100644 index e593da0..0000000 --- a/src/lib/Xmobar/X11/MinXft.hsc +++ /dev/null @@ -1,333 +0,0 @@ ------------------------------------------------------------------------------- --- | --- Module: MinXft --- Copyright: (c) 2012, 2014, 2015, 2017 Jose Antonio Ortega Ruiz --- (c) Clemens Fruhwirth <clemens@endorphin.org> 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 <X11/Xft/Xft.h> - --- 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 <X11/extensions/Xrender.h> - -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/Parsers.hs b/src/lib/Xmobar/X11/Parsers.hs deleted file mode 100644 index 8c1abac..0000000 --- a/src/lib/Xmobar/X11/Parsers.hs +++ /dev/null @@ -1,146 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} - ------------------------------------------------------------------------------ --- | --- Module : Xmobar.Parsers --- Copyright : (c) Andrea Rossato --- License : BSD-style (see LICENSE) --- --- Maintainer : Jose A. Ortega Ruiz <jao@gnu.org> --- Stability : unstable --- Portability : unportable --- --- Parsing for template substrings --- ------------------------------------------------------------------------------ - -module Xmobar.X11.Parsers (parseString, Widget(..)) where - -import Xmobar.Config -import Xmobar.Actions - -import Control.Monad (guard, mzero) -import Text.ParserCombinators.Parsec -import Graphics.X11.Types (Button) - -data Widget = Icon String | Text String - -type ColorString = String -type FontIndex = Int - --- | Runs the string parser -parseString :: Config -> String - -> IO [(Widget, ColorString, FontIndex, Maybe [Action])] -parseString c s = - case parse (stringParser (fgColor c) 0 Nothing) "" s of - Left _ -> return [(Text $ "Could not parse string: " ++ s - , fgColor c - , 0 - , Nothing)] - Right x -> return (concat x) - -allParsers :: ColorString - -> FontIndex - -> Maybe [Action] - -> Parser [(Widget, ColorString, FontIndex, Maybe [Action])] -allParsers c f a = textParser c f a - <|> try (iconParser c f a) - <|> try (rawParser c f a) - <|> try (actionParser c f a) - <|> try (fontParser c a) - <|> colorParser f a - --- | Gets the string and combines the needed parsers -stringParser :: String -> FontIndex -> Maybe [Action] - -> Parser [[(Widget, ColorString, FontIndex, Maybe [Action])]] -stringParser c f a = manyTill (allParsers c f a) eof - --- | Parses a maximal string without color markup. -textParser :: String -> FontIndex -> Maybe [Action] - -> Parser [(Widget, ColorString, FontIndex, Maybe [Action])] -textParser c f a = do s <- many1 $ - noneOf "<" <|> - try (notFollowedBy' (char '<') - (try (string "fc=") <|> - try (string "fn=") <|> - try (string "action=") <|> - try (string "/action>") <|> - try (string "icon=") <|> - try (string "raw=") <|> - try (string "/fn>") <|> - string "/fc>")) - return [(Text s, c, f, a)] - --- | Parse a "raw" tag, which we use to prevent other tags from creeping in. --- The format here is net-string-esque: a literal "<raw=" followed by a --- string of digits (base 10) denoting the length of the raw string, --- a literal ":" as digit-string-terminator, the raw string itself, and --- then a literal "/>". -rawParser :: ColorString - -> FontIndex - -> Maybe [Action] - -> Parser [(Widget, ColorString, FontIndex, Maybe [Action])] -rawParser c f a = do - string "<raw=" - lenstr <- many1 digit - char ':' - case reads lenstr of - [(len,[])] -> do - guard ((len :: Integer) <= fromIntegral (maxBound :: Int)) - s <- count (fromIntegral len) anyChar - string "/>" - return [(Text s, c, f, a)] - _ -> mzero - --- | Wrapper for notFollowedBy that returns the result of the first parser. --- Also works around the issue that, at least in Parsec 3.0.0, notFollowedBy --- accepts only parsers with return type Char. -notFollowedBy' :: Parser a -> Parser b -> Parser a -notFollowedBy' p e = do x <- p - notFollowedBy $ try (e >> return '*') - return x - -iconParser :: String -> FontIndex -> Maybe [Action] - -> Parser [(Widget, ColorString, FontIndex, Maybe [Action])] -iconParser c f a = do - string "<icon=" - i <- manyTill (noneOf ">") (try (string "/>")) - return [(Icon i, c, f, a)] - -actionParser :: String -> FontIndex -> Maybe [Action] - -> Parser [(Widget, ColorString, FontIndex, Maybe [Action])] -actionParser c f act = do - string "<action=" - command <- choice [between (char '`') (char '`') (many1 (noneOf "`")), - many1 (noneOf ">")] - buttons <- (char '>' >> return "1") <|> (space >> spaces >> - between (string "button=") (string ">") (many1 (oneOf "12345"))) - let a = Spawn (toButtons buttons) command - a' = case act of - Nothing -> Just [a] - Just act' -> Just $ a : act' - s <- manyTill (allParsers c f a') (try $ string "</action>") - return (concat s) - -toButtons :: String -> [Button] -toButtons = map (\x -> read [x]) - --- | Parsers a string wrapped in a color specification. -colorParser :: FontIndex -> Maybe [Action] - -> Parser [(Widget, ColorString, FontIndex, Maybe [Action])] -colorParser f a = do - c <- between (string "<fc=") (string ">") colors - s <- manyTill (allParsers c f a) (try $ string "</fc>") - return (concat s) - --- | Parsers a string wrapped in a font specification. -fontParser :: ColorString -> Maybe [Action] - -> Parser [(Widget, ColorString, FontIndex, Maybe [Action])] -fontParser c a = do - f <- between (string "<fn=") (string ">") colors - s <- manyTill (allParsers c (read f) a) (try $ string "</fn>") - return (concat s) - --- | Parses a color specification (hex or named) -colors :: Parser String -colors = many1 (alphaNum <|> char ',' <|> char '#') diff --git a/src/lib/Xmobar/X11/Types.hs b/src/lib/Xmobar/X11/Types.hs deleted file mode 100644 index c5c7ade..0000000 --- a/src/lib/Xmobar/X11/Types.hs +++ /dev/null @@ -1,40 +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.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 deleted file mode 100644 index 78f4b26..0000000 --- a/src/lib/Xmobar/X11/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 <jao@gnu.org> --- 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/XPMFile.hsc b/src/lib/Xmobar/X11/XPMFile.hsc deleted file mode 100644 index 2daffac..0000000 --- a/src/lib/Xmobar/X11/XPMFile.hsc +++ /dev/null @@ -1,60 +0,0 @@ -{-# LANGUAGE FlexibleContexts, ForeignFunctionInterface #-} ------------------------------------------------------------------------------ --- | --- Module : XPMFile --- Copyright : (C) 2014, 2018 Alexander Shabalin --- License : BSD3 --- --- Maintainer : jao@gnu.org --- Stability : unstable --- Portability : unportable --- ------------------------------------------------------------------------------ - -module Xmobar.X11.XPMFile(readXPMFile) where - -#if MIN_VERSION_mtl(2, 2, 1) -import Control.Monad.Except(MonadError(..)) -#else -import Control.Monad.Error(MonadError(..)) -#endif -import Control.Monad.Trans(MonadIO(..)) -import Graphics.X11.Xlib(Dimension, Display(..), Drawable, Pixmap) -import Foreign.C.String(CString, withCString) -import Foreign.C.Types(CInt(..), CLong) -import Foreign.Ptr(Ptr) -import Foreign.Marshal.Alloc(alloca, allocaBytes) -import Foreign.Storable(peek, peekByteOff, pokeByteOff) - -#include <X11/xpm.h> - -foreign import ccall "XpmReadFileToPixmap" - xpmReadFileToPixmap :: Display -> Drawable -> CString -> Ptr Pixmap -> Ptr Pixmap -> Ptr () -> IO CInt - -readXPMFile - :: (MonadError String m, MonadIO m) - => Display - -> Drawable - -> String - -> m (Dimension, Dimension, Pixmap, Maybe Pixmap) -readXPMFile display d filename = - toError $ withCString filename $ \c_filename -> - alloca $ \pixmap_return -> - alloca $ \shapemask_return -> - allocaBytes (#size XpmAttributes) $ \attributes -> do - (#poke XpmAttributes, valuemask) attributes ((#const XpmReturnAllocPixels) :: CLong) - res <- xpmReadFileToPixmap display d c_filename pixmap_return shapemask_return attributes - case res of - 0 -> do - width <- (#peek XpmAttributes, width) attributes - height <- (#peek XpmAttributes, height) attributes - pixmap <- peek pixmap_return - shapemask <- peek shapemask_return - return $ Right (width, height, pixmap, if shapemask == 0 then Nothing else Just shapemask) - 1 -> return $ Left "readXPMFile: XpmColorError" - -1 -> return $ Left "readXPMFile: XpmOpenFailed" - -2 -> return $ Left "readXPMFile: XpmFileInvalid" - -3 -> return $ Left "readXPMFile: XpmNoMemory" - -4 -> return $ Left "readXPMFile: XpmColorFailed" - _ -> return $ Left "readXPMFile: Unknown error" - where toError m = either throwError return =<< liftIO m diff --git a/src/lib/Xmobar/X11/XUtil.hs b/src/lib/Xmobar/X11/XUtil.hs deleted file mode 100644 index 6e9eb2b..0000000 --- a/src/lib/Xmobar/X11/XUtil.hs +++ /dev/null @@ -1,129 +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.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 |