summaryrefslogtreecommitdiffhomepage
path: root/src/Xmobar/X11
diff options
context:
space:
mode:
authorjao <jao@gnu.org>2018-11-25 15:10:29 +0000
committerjao <jao@gnu.org>2018-11-25 15:10:29 +0000
commit77df1ac30fa7af5948f7ff64f5fee9aed64552b3 (patch)
tree647a4eb67ff1c293a5c530538ee88fc0093b577a /src/Xmobar/X11
parente0d6da82de8d0d1cef98896164c6016b84e47068 (diff)
downloadxmobar-77df1ac30fa7af5948f7ff64f5fee9aed64552b3.tar.gz
xmobar-77df1ac30fa7af5948f7ff64f5fee9aed64552b3.tar.bz2
Back to app/src, since it seems they're the default convention for stack
Diffstat (limited to 'src/Xmobar/X11')
-rw-r--r--src/Xmobar/X11/Bitmap.hs130
-rw-r--r--src/Xmobar/X11/ColorCache.hs111
-rw-r--r--src/Xmobar/X11/Draw.hs151
-rw-r--r--src/Xmobar/X11/MinXft.hsc333
-rw-r--r--src/Xmobar/X11/Parsers.hs146
-rw-r--r--src/Xmobar/X11/Types.hs40
-rw-r--r--src/Xmobar/X11/Window.hs229
-rw-r--r--src/Xmobar/X11/XPMFile.hsc60
-rw-r--r--src/Xmobar/X11/XUtil.hs129
9 files changed, 1329 insertions, 0 deletions
diff --git a/src/Xmobar/X11/Bitmap.hs b/src/Xmobar/X11/Bitmap.hs
new file mode 100644
index 0000000..c0dba14
--- /dev/null
+++ b/src/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.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/Xmobar/X11/ColorCache.hs b/src/Xmobar/X11/ColorCache.hs
new file mode 100644
index 0000000..4d22e16
--- /dev/null
+++ b/src/Xmobar/X11/ColorCache.hs
@@ -0,0 +1,111 @@
+{-# 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/Xmobar/X11/Draw.hs b/src/Xmobar/X11/Draw.hs
new file mode 100644
index 0000000..d0c78a8
--- /dev/null
+++ b/src/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.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/Xmobar/X11/MinXft.hsc b/src/Xmobar/X11/MinXft.hsc
new file mode 100644
index 0000000..e593da0
--- /dev/null
+++ b/src/Xmobar/X11/MinXft.hsc
@@ -0,0 +1,333 @@
+------------------------------------------------------------------------------
+-- |
+-- 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/Xmobar/X11/Parsers.hs b/src/Xmobar/X11/Parsers.hs
new file mode 100644
index 0000000..8c1abac
--- /dev/null
+++ b/src/Xmobar/X11/Parsers.hs
@@ -0,0 +1,146 @@
+{-# 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/Xmobar/X11/Types.hs b/src/Xmobar/X11/Types.hs
new file mode 100644
index 0000000..c5c7ade
--- /dev/null
+++ b/src/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/Xmobar/X11/Window.hs b/src/Xmobar/X11/Window.hs
new file mode 100644
index 0000000..78f4b26
--- /dev/null
+++ b/src/Xmobar/X11/Window.hs
@@ -0,0 +1,229 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : Window
+-- Copyright : (c) 2011-18 Jose A. Ortega Ruiz
+-- : (c) 2012 Jochen Keil
+-- License : BSD-style (see LICENSE)
+--
+-- Maintainer : Jose A. Ortega Ruiz <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/Xmobar/X11/XPMFile.hsc b/src/Xmobar/X11/XPMFile.hsc
new file mode 100644
index 0000000..2daffac
--- /dev/null
+++ b/src/Xmobar/X11/XPMFile.hsc
@@ -0,0 +1,60 @@
+{-# 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/Xmobar/X11/XUtil.hs b/src/Xmobar/X11/XUtil.hs
new file mode 100644
index 0000000..6e9eb2b
--- /dev/null
+++ b/src/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