summaryrefslogtreecommitdiffhomepage
path: root/src/lib/Xmobar/X11
diff options
context:
space:
mode:
Diffstat (limited to 'src/lib/Xmobar/X11')
-rw-r--r--src/lib/Xmobar/X11/Bitmap.hs130
-rw-r--r--src/lib/Xmobar/X11/ColorCache.hs111
-rw-r--r--src/lib/Xmobar/X11/Draw.hs151
-rw-r--r--src/lib/Xmobar/X11/MinXft.hsc333
-rw-r--r--src/lib/Xmobar/X11/Parsers.hs146
-rw-r--r--src/lib/Xmobar/X11/Types.hs40
-rw-r--r--src/lib/Xmobar/X11/Window.hs229
-rw-r--r--src/lib/Xmobar/X11/XPMFile.hsc60
-rw-r--r--src/lib/Xmobar/X11/XUtil.hs129
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