{-# LINE 1 "src/Xmobar/X11/MinXft.hsc" #-}
------------------------------------------------------------------------------
-- |
-- 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)



-- Color Handling

newtype AXftColor = AXftColor (Ptr AXftColor)

foreign import ccall "XftColorAllocName"
    cXftColorAllocName :: Display -> Visual -> Colormap -> CString -> AXftColor -> IO (Int32)
{-# LINE 68 "src/Xmobar/X11/MinXft.hsc" #-}

-- 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 :: Display -> Visual -> Colormap -> String -> IO AXftColor
mallocAXftColor Display
d Visual
v Colormap
cm String
n = do
  Ptr AXftColor
color <- Int -> IO (Ptr AXftColor)
forall a. Int -> IO (Ptr a)
mallocBytes ((Int
16))
{-# LINE 74 "src/Xmobar/X11/MinXft.hsc" #-}
  withCAString n $ \str -> cXftColorAllocName d v cm str (AXftColor color)
  AXftColor -> IO AXftColor
forall (m :: * -> *) a. Monad m => a -> m a
return (Ptr AXftColor -> AXftColor
AXftColor Ptr 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 -> IO Int
xft_ascent (AXftFont Ptr AXftFont
p) = Ptr AXftFont -> CInt -> IO Int
forall a. Ptr a -> CInt -> IO Int
peekCUShort Ptr AXftFont
p (CInt
0)
{-# LINE 86 "src/Xmobar/X11/MinXft.hsc" #-}

xft_ascent' :: [AXftFont] -> IO Int
xft_ascent' :: [AXftFont] -> IO Int
xft_ascent' = (([Int] -> Int) -> IO [Int] -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum) (IO [Int] -> IO Int)
-> ([AXftFont] -> IO [Int]) -> [AXftFont] -> IO Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((AXftFont -> IO Int) -> [AXftFont] -> IO [Int]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM AXftFont -> IO Int
xft_ascent)

xft_descent :: AXftFont -> IO Int
xft_descent :: AXftFont -> IO Int
xft_descent (AXftFont Ptr AXftFont
p) = Ptr AXftFont -> CInt -> IO Int
forall a. Ptr a -> CInt -> IO Int
peekCUShort Ptr AXftFont
p (CInt
4)
{-# LINE 92 "src/Xmobar/X11/MinXft.hsc" #-}

xft_descent' :: [AXftFont] -> IO Int
xft_descent' :: [AXftFont] -> IO Int
xft_descent' = (([Int] -> Int) -> IO [Int] -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum) (IO [Int] -> IO Int)
-> ([AXftFont] -> IO [Int]) -> [AXftFont] -> IO Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((AXftFont -> IO Int) -> [AXftFont] -> IO [Int]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM AXftFont -> IO Int
xft_descent)

xft_height :: AXftFont -> IO Int
xft_height :: AXftFont -> IO Int
xft_height (AXftFont Ptr AXftFont
p) = Ptr AXftFont -> CInt -> IO Int
forall a. Ptr a -> CInt -> IO Int
peekCUShort Ptr AXftFont
p (CInt
8)
{-# LINE 98 "src/Xmobar/X11/MinXft.hsc" #-}

xft_height' :: [AXftFont] -> IO Int
xft_height' :: [AXftFont] -> IO Int
xft_height' = (([Int] -> Int) -> IO [Int] -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum) (IO [Int] -> IO Int)
-> ([AXftFont] -> IO [Int]) -> [AXftFont] -> IO Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((AXftFont -> IO Int) -> [AXftFont] -> IO [Int]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM AXftFont -> IO Int
xft_height)

foreign import ccall "XftTextExtentsUtf8"
  cXftTextExtentsUtf8 :: Display -> AXftFont -> CString -> CInt -> Ptr XGlyphInfo -> IO ()

xftTxtExtents :: Display -> AXftFont -> String -> IO XGlyphInfo
xftTxtExtents :: Display -> AXftFont -> String -> IO XGlyphInfo
xftTxtExtents Display
d AXftFont
f String
string =
    [CChar] -> (Int -> CString -> IO XGlyphInfo) -> IO XGlyphInfo
forall a b. Storable a => [a] -> (Int -> Ptr a -> IO b) -> IO b
withArrayLen ((Word8 -> CChar) -> [Word8] -> [CChar]
forall a b. (a -> b) -> [a] -> [b]
map Word8 -> CChar
forall a b. (Integral a, Num b) => a -> b
fi (String -> [Word8]
UTF8.encode String
string)) ((Int -> CString -> IO XGlyphInfo) -> IO XGlyphInfo)
-> (Int -> CString -> IO XGlyphInfo) -> IO XGlyphInfo
forall a b. (a -> b) -> a -> b
$
    \Int
len CString
str_ptr -> (Ptr XGlyphInfo -> IO XGlyphInfo) -> IO XGlyphInfo
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr XGlyphInfo -> IO XGlyphInfo) -> IO XGlyphInfo)
-> (Ptr XGlyphInfo -> IO XGlyphInfo) -> IO XGlyphInfo
forall a b. (a -> b) -> a -> b
$
    \Ptr XGlyphInfo
cglyph -> do
      Display -> AXftFont -> CString -> CInt -> Ptr XGlyphInfo -> IO ()
cXftTextExtentsUtf8 Display
d AXftFont
f CString
str_ptr (Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fi Int
len) Ptr XGlyphInfo
cglyph
      Ptr XGlyphInfo -> IO XGlyphInfo
forall a. Storable a => Ptr a -> IO a
peek Ptr XGlyphInfo
cglyph

xftTxtExtents' :: Display -> [AXftFont] -> String -> IO XGlyphInfo
xftTxtExtents' :: Display -> [AXftFont] -> String -> IO XGlyphInfo
xftTxtExtents' Display
d [AXftFont]
fs String
string = do
    [(AXftFont, String, XGlyphInfo, Integer, Integer)]
chunks <- Display
-> [AXftFont]
-> String
-> IO [(AXftFont, String, XGlyphInfo, Integer, Integer)]
getChunks Display
d [AXftFont]
fs String
string
    let (AXftFont
_, String
_, XGlyphInfo
gi, Integer
_, Integer
_) = [(AXftFont, String, XGlyphInfo, Integer, Integer)]
-> (AXftFont, String, XGlyphInfo, Integer, Integer)
forall a. [a] -> a
last [(AXftFont, String, XGlyphInfo, Integer, Integer)]
chunks
    XGlyphInfo -> IO XGlyphInfo
forall (m :: * -> *) a. Monad m => a -> m a
return XGlyphInfo
gi

foreign import ccall "XftFontOpenName"
  c_xftFontOpen :: Display -> CInt -> CString -> IO AXftFont

openAXftFont :: Display -> Screen -> String -> IO AXftFont
openAXftFont :: Display -> Screen -> String -> IO AXftFont
openAXftFont Display
dpy Screen
screen String
name =
    String -> (CString -> IO AXftFont) -> IO AXftFont
forall a. String -> (CString -> IO a) -> IO a
withCAString String
name ((CString -> IO AXftFont) -> IO AXftFont)
-> (CString -> IO AXftFont) -> IO AXftFont
forall a b. (a -> b) -> a -> b
$
      \CString
cname -> Display -> CInt -> CString -> IO AXftFont
c_xftFontOpen Display
dpy (ScreenNumber -> CInt
forall a b. (Integral a, Num b) => a -> b
fi (Screen -> ScreenNumber
screenNumberOfScreen Screen
screen)) CString
cname

foreign import ccall "XftFontClose"
  closeAXftFont :: Display -> AXftFont -> IO ()

foreign import ccall "XftCharExists"
  cXftCharExists :: Display -> AXftFont -> (Word32) -> IO (Int32)
{-# LINE 132 "src/Xmobar/X11/MinXft.hsc" #-}

xftCharExists :: Display -> AXftFont -> Char -> IO Bool
xftCharExists :: Display -> AXftFont -> Char -> IO Bool
xftCharExists Display
d AXftFont
f Char
c = Int32 -> Bool
forall a. (Eq a, Num a) => a -> Bool
bool (Int32 -> Bool) -> IO Int32 -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Display -> AXftFont -> ScreenNumber -> IO Int32
cXftCharExists Display
d AXftFont
f (Int -> ScreenNumber
forall a b. (Integral a, Num b) => a -> b
fi (Int -> ScreenNumber) -> Int -> ScreenNumber
forall a b. (a -> b) -> a -> b
$ Char -> Int
ord Char
c)
  where
    bool :: a -> Bool
bool a
0 = Bool
False
    bool a
_ = Bool
True
-- Drawing

fi :: (Integral a, Num b) => a -> b
fi :: a -> b
fi = a -> b
forall a b. (Integral a, Num b) => a -> b
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 :: Display
-> Colormap -> Visual -> Colormap -> (AXftDraw -> IO a) -> IO a
withAXftDraw Display
d Colormap
p Visual
v Colormap
c AXftDraw -> IO a
act = do
  AXftDraw
draw <- Display -> Colormap -> Visual -> Colormap -> IO AXftDraw
c_xftDrawCreate Display
d Colormap
p Visual
v Colormap
c
  a
a <- AXftDraw -> IO a
act AXftDraw
draw
  AXftDraw -> IO ()
c_xftDrawDestroy AXftDraw
draw
  a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a

foreign import ccall "XftDrawStringUtf8"
  cXftDrawStringUtf8 :: AXftDraw -> AXftColor -> AXftFont -> CInt -> CInt -> Ptr (Word8) -> CInt -> IO ()
{-# LINE 163 "src/Xmobar/X11/MinXft.hsc" #-}

drawXftString :: (Integral a1, Integral a) =>
                 AXftDraw -> AXftColor -> AXftFont -> a -> a1 -> String -> IO ()
drawXftString :: AXftDraw -> AXftColor -> AXftFont -> a -> a1 -> String -> IO ()
drawXftString AXftDraw
d AXftColor
c AXftFont
f a
x a1
y String
string =
    [Word8] -> (Int -> Ptr Word8 -> IO ()) -> IO ()
forall a b. Storable a => [a] -> (Int -> Ptr a -> IO b) -> IO b
withArrayLen ((Word8 -> Word8) -> [Word8] -> [Word8]
forall a b. (a -> b) -> [a] -> [b]
map Word8 -> Word8
forall a b. (Integral a, Num b) => a -> b
fi (String -> [Word8]
UTF8.encode String
string))
      (\Int
len Ptr Word8
ptr -> AXftDraw
-> AXftColor
-> AXftFont
-> CInt
-> CInt
-> Ptr Word8
-> CInt
-> IO ()
cXftDrawStringUtf8 AXftDraw
d AXftColor
c AXftFont
f (a -> CInt
forall a b. (Integral a, Num b) => a -> b
fi a
x) (a1 -> CInt
forall a b. (Integral a, Num b) => a -> b
fi a1
y) Ptr Word8
ptr (Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fi Int
len))

drawXftString' :: AXftDraw ->
                  AXftColor ->
                  [AXftFont] ->
                  Integer ->
                  Integer ->
                  String -> IO ()
drawXftString' :: AXftDraw
-> AXftColor -> [AXftFont] -> Integer -> Integer -> String -> IO ()
drawXftString' AXftDraw
d AXftColor
c [AXftFont]
fs Integer
x Integer
y String
string = do
    Display
display <- AXftDraw -> IO Display
c_xftDrawDisplay AXftDraw
d
    [(AXftFont, String, XGlyphInfo, Integer, Integer)]
chunks <- Display
-> [AXftFont]
-> String
-> IO [(AXftFont, String, XGlyphInfo, Integer, Integer)]
getChunks Display
display [AXftFont]
fs String
string
    ((AXftFont, String, XGlyphInfo, Integer, Integer) -> IO ())
-> [(AXftFont, String, XGlyphInfo, Integer, Integer)] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\(AXftFont
f, String
s, XGlyphInfo
_, Integer
xo, Integer
yo) -> AXftDraw
-> AXftColor -> AXftFont -> Integer -> Integer -> String -> IO ()
forall a1 a.
(Integral a1, Integral a) =>
AXftDraw -> AXftColor -> AXftFont -> a -> a1 -> String -> IO ()
drawXftString AXftDraw
d AXftColor
c AXftFont
f (Integer
xInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
+Integer
xo) (Integer
yInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
+Integer
yo) String
s) [(AXftFont, String, XGlyphInfo, Integer, Integer)]
chunks

-- Split string and determine fonts/offsets for individual parts
getChunks :: Display -> [AXftFont] -> String ->
             IO [(AXftFont, String, XGlyphInfo, Integer, Integer)]
getChunks :: Display
-> [AXftFont]
-> String
-> IO [(AXftFont, String, XGlyphInfo, Integer, Integer)]
getChunks Display
disp [AXftFont]
fts String
str = do
    [(AXftFont, String)]
chunks <- Display -> [AXftFont] -> String -> IO [(AXftFont, String)]
getFonts Display
disp [AXftFont]
fts String
str
    XGlyphInfo
-> [(AXftFont, String)]
-> IO [(AXftFont, String, XGlyphInfo, Integer, Integer)]
forall d e.
(Num d, Num e) =>
XGlyphInfo
-> [(AXftFont, String)]
-> IO [(AXftFont, String, XGlyphInfo, d, e)]
getOffsets (Int -> Int -> Int -> Int -> Int -> Int -> XGlyphInfo
XGlyphInfo Int
0 Int
0 Int
0 Int
0 Int
0 Int
0) [(AXftFont, String)]
chunks
  where
    -- Split string and determine fonts for individual parts
    getFonts :: Display -> [AXftFont] -> String -> IO [(AXftFont, String)]
getFonts Display
_ [] String
_ = [(AXftFont, String)] -> IO [(AXftFont, String)]
forall (m :: * -> *) a. Monad m => a -> m a
return []
    getFonts Display
_ [AXftFont]
_ [] = [(AXftFont, String)] -> IO [(AXftFont, String)]
forall (m :: * -> *) a. Monad m => a -> m a
return []
    getFonts Display
_ [AXftFont
ft] String
s = [(AXftFont, String)] -> IO [(AXftFont, String)]
forall (m :: * -> *) a. Monad m => a -> m a
return [(AXftFont
ft, String
s)]
    getFonts Display
d fonts :: [AXftFont]
fonts@(AXftFont
ft:[AXftFont]
_) String
s = do
        -- Determine which glyph can be rendered by current font
        [Bool]
glyphs <- (Char -> IO Bool) -> String -> IO [Bool]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Display -> AXftFont -> Char -> IO Bool
xftCharExists Display
d AXftFont
ft) String
s
        -- Split string into parts that can/cannot be rendered
        let splits :: [(Bool, String)]
splits = [(Bool, Int)] -> String -> [(Bool, String)]
forall a a. [(a, Int)] -> [a] -> [(a, [a])]
split ([Bool] -> [(Bool, Int)]
forall a. Eq a => [a] -> [(a, Int)]
runs [Bool]
glyphs) String
s
        -- Determine which font to render each chunk with
        [[(AXftFont, String)]] -> [(AXftFont, String)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[(AXftFont, String)]] -> [(AXftFont, String)])
-> IO [[(AXftFont, String)]] -> IO [(AXftFont, String)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` ((Bool, String) -> IO [(AXftFont, String)])
-> [(Bool, String)] -> IO [[(AXftFont, String)]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Display -> [AXftFont] -> (Bool, String) -> IO [(AXftFont, String)]
getFont Display
d [AXftFont]
fonts) [(Bool, String)]
splits

    -- Determine fonts for substrings
    getFont :: Display -> [AXftFont] -> (Bool, String) -> IO [(AXftFont, String)]
getFont Display
_ [] (Bool, String)
_ = [(AXftFont, String)] -> IO [(AXftFont, String)]
forall (m :: * -> *) a. Monad m => a -> m a
return []
    getFont Display
_ [AXftFont
ft] (Bool
_, String
s) = [(AXftFont, String)] -> IO [(AXftFont, String)]
forall (m :: * -> *) a. Monad m => a -> m a
return [(AXftFont
ft, String
s)] -- Last font, use it
    getFont Display
_ (AXftFont
ft:[AXftFont]
_) (Bool
True, String
s) = [(AXftFont, String)] -> IO [(AXftFont, String)]
forall (m :: * -> *) a. Monad m => a -> m a
return [(AXftFont
ft, String
s)] -- Current font can render this substring
    getFont Display
d (AXftFont
_:[AXftFont]
fs) (Bool
False, String
s) = Display -> [AXftFont] -> String -> IO [(AXftFont, String)]
getFonts Display
d [AXftFont]
fs String
s -- Fallback to next font

    -- Helpers
    runs :: [a] -> [(a, Int)]
runs [] = []
    runs (a
x:[a]
xs) = let ([a]
h, [a]
t) = (a -> Bool) -> [a] -> ([a], [a])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (a -> a -> Bool
forall a. Eq a => a -> a -> Bool
==a
x) [a]
xs in (a
x, [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
h Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (a, Int) -> [(a, Int)] -> [(a, Int)]
forall a. a -> [a] -> [a]
: [a] -> [(a, Int)]
runs [a]
t
    split :: [(a, Int)] -> [a] -> [(a, [a])]
split [] [a]
_ = []
    split ((a
x, Int
c):[(a, Int)]
xs) [a]
s = let ([a]
h, [a]
t) = Int -> [a] -> ([a], [a])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
c [a]
s in (a
x, [a]
h) (a, [a]) -> [(a, [a])] -> [(a, [a])]
forall a. a -> [a] -> [a]
: [(a, Int)] -> [a] -> [(a, [a])]
split [(a, Int)]
xs [a]
t

    -- Determine coordinates for chunks using extents
    getOffsets :: XGlyphInfo
-> [(AXftFont, String)]
-> IO [(AXftFont, String, XGlyphInfo, d, e)]
getOffsets XGlyphInfo
_ [] = [(AXftFont, String, XGlyphInfo, d, e)]
-> IO [(AXftFont, String, XGlyphInfo, d, e)]
forall (m :: * -> *) a. Monad m => a -> m a
return []
    getOffsets (XGlyphInfo Int
_ Int
_ Int
x Int
y Int
xo Int
yo) ((AXftFont
f, String
s):[(AXftFont, String)]
chunks) = do
        (XGlyphInfo Int
w' Int
h' Int
_ Int
_ Int
xo' Int
yo') <- Display -> AXftFont -> String -> IO XGlyphInfo
xftTxtExtents Display
disp AXftFont
f String
s
        let gi :: XGlyphInfo
gi = Int -> Int -> Int -> Int -> Int -> Int -> XGlyphInfo
XGlyphInfo (Int
xoInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
w') (Int
yoInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
h') Int
x Int
y (Int
xoInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
xo') (Int
yoInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
yo')
        [(AXftFont, String, XGlyphInfo, d, e)]
rest <- XGlyphInfo
-> [(AXftFont, String)]
-> IO [(AXftFont, String, XGlyphInfo, d, e)]
getOffsets XGlyphInfo
gi [(AXftFont, String)]
chunks
        [(AXftFont, String, XGlyphInfo, d, e)]
-> IO [(AXftFont, String, XGlyphInfo, d, e)]
forall (m :: * -> *) a. Monad m => a -> m a
return ([(AXftFont, String, XGlyphInfo, d, e)]
 -> IO [(AXftFont, String, XGlyphInfo, d, e)])
-> [(AXftFont, String, XGlyphInfo, d, e)]
-> IO [(AXftFont, String, XGlyphInfo, d, e)]
forall a b. (a -> b) -> a -> b
$ (AXftFont
f, String
s, XGlyphInfo
gi, Int -> d
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
xo, Int -> e
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
yo) (AXftFont, String, XGlyphInfo, d, e)
-> [(AXftFont, String, XGlyphInfo, d, e)]
-> [(AXftFont, String, XGlyphInfo, d, e)]
forall a. a -> [a] -> [a]
: [(AXftFont, String, XGlyphInfo, d, e)]
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 :: AXftDraw -> AXftColor -> a -> a1 -> a2 -> a3 -> IO ()
drawXftRect AXftDraw
draw AXftColor
color a
x a1
y a2
width a3
height =
  AXftDraw -> AXftColor -> CInt -> CInt -> CUInt -> CUInt -> IO ()
cXftDrawRect AXftDraw
draw AXftColor
color (a -> CInt
forall a b. (Integral a, Num b) => a -> b
fi a
x) (a1 -> CInt
forall a b. (Integral a, Num b) => a -> b
fi a1
y) (a2 -> CUInt
forall a b. (Integral a, Num b) => a -> b
fi a2
width) (a3 -> CUInt
forall a b. (Integral a, Num b) => a -> b
fi a3
height)



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 :: XRenderPictureAttributes -> Int
sizeOf XRenderPictureAttributes
_ = (Int
72)
{-# LINE 254 "src/Xmobar/X11/MinXft.hsc" #-}
    alignment _ = alignment (undefined :: CInt)
    peek :: Ptr XRenderPictureAttributes -> IO XRenderPictureAttributes
peek Ptr XRenderPictureAttributes
_ = XRenderPictureAttributes -> IO XRenderPictureAttributes
forall (m :: * -> *) a. Monad m => a -> m a
return XRenderPictureAttributes
XRenderPictureAttributes
    poke :: Ptr XRenderPictureAttributes -> XRenderPictureAttributes -> IO ()
poke Ptr XRenderPictureAttributes
p XRenderPictureAttributes
XRenderPictureAttributes =
        Ptr XRenderPictureAttributes -> CInt -> CSize -> IO ()
forall a. Ptr a -> CInt -> CSize -> IO ()
memset Ptr XRenderPictureAttributes
p CInt
0 (CSize
72)
{-# LINE 258 "src/Xmobar/X11/MinXft.hsc" #-}

-- | Convenience function, gives us an XRender handle to a traditional
-- Pixmap.  Don't let it escape.
withRenderPicture :: Display -> Drawable -> (Picture -> IO a) -> IO ()
withRenderPicture :: Display -> Colormap -> (Colormap -> IO a) -> IO ()
withRenderPicture Display
d Colormap
p Colormap -> IO a
f = do
    Ptr XRenderPictFormat
format <- Display -> CInt -> IO (Ptr XRenderPictFormat)
xRenderFindStandardFormat Display
d CInt
1 -- PictStandardRGB24
    (Ptr XRenderPictureAttributes -> IO ()) -> IO ()
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr XRenderPictureAttributes -> IO ()) -> IO ())
-> (Ptr XRenderPictureAttributes -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr XRenderPictureAttributes
attr -> do
        Colormap
pic <- Display
-> Colormap
-> Ptr XRenderPictFormat
-> CULong
-> Ptr XRenderPictureAttributes
-> IO Colormap
xRenderCreatePicture Display
d Colormap
p Ptr XRenderPictFormat
format CULong
0 Ptr XRenderPictureAttributes
attr
        Colormap -> IO a
f Colormap
pic
        Display -> Colormap -> IO ()
xRenderFreePicture Display
d Colormap
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 :: Display -> XRenderColor -> (Colormap -> IO a) -> IO ()
withRenderFill Display
d XRenderColor
c Colormap -> IO a
f = do
    Colormap
pic <- XRenderColor -> (Ptr XRenderColor -> IO Colormap) -> IO Colormap
forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b
with XRenderColor
c (Display -> Ptr XRenderColor -> IO Colormap
xRenderCreateSolidFill Display
d)
    Colormap -> IO a
f Colormap
pic
    Display -> Colormap -> IO ()
xRenderFreePicture Display
d Colormap
pic

-- | Drawing the background to a pixmap and taking into account
-- transparency
drawBackground ::  Display -> Drawable -> String -> Int -> Rectangle -> IO ()
drawBackground :: Display -> Colormap -> String -> Int -> Rectangle -> IO ()
drawBackground Display
d Colormap
p String
bgc Int
alpha (Rectangle Int32
x Int32
y ScreenNumber
wid ScreenNumber
ht) = do
  let render :: CInt -> Colormap -> Colormap -> Colormap -> IO ()
render CInt
opt Colormap
bg Colormap
pic Colormap
m =
        Display
-> CInt
-> Colormap
-> Colormap
-> Colormap
-> CInt
-> CInt
-> CInt
-> CInt
-> CInt
-> CInt
-> CUInt
-> CUInt
-> IO ()
xRenderComposite Display
d CInt
opt Colormap
bg Colormap
m Colormap
pic
                        (Int32 -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
x) (Int32 -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
y) CInt
0 CInt
0
                        CInt
0 CInt
0 (ScreenNumber -> CUInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral ScreenNumber
wid) (ScreenNumber -> CUInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral ScreenNumber
ht)
  Display -> Colormap -> (Colormap -> IO ()) -> IO ()
forall a. Display -> Colormap -> (Colormap -> IO a) -> IO ()
withRenderPicture Display
d Colormap
p ((Colormap -> IO ()) -> IO ()) -> (Colormap -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Colormap
pic -> do
    -- Handle background color
    XRenderColor
bgcolor <- Display -> String -> IO XRenderColor
parseRenderColor Display
d String
bgc
    Display -> XRenderColor -> (Colormap -> IO ()) -> IO ()
forall a. Display -> XRenderColor -> (Colormap -> IO a) -> IO ()
withRenderFill Display
d XRenderColor
bgcolor ((Colormap -> IO ()) -> IO ()) -> (Colormap -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Colormap
bgfill ->
      Display -> XRenderColor -> (Colormap -> IO ()) -> IO ()
forall a. Display -> XRenderColor -> (Colormap -> IO a) -> IO ()
withRenderFill Display
d
                     (Int -> Int -> Int -> Int -> XRenderColor
XRenderColor Int
0 Int
0 Int
0 (Int
257 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
alpha))
                     (CInt -> Colormap -> Colormap -> Colormap -> IO ()
render CInt
pictOpSrc Colormap
bgfill Colormap
pic)
    -- Handle transparency
    Display -> String -> Bool -> IO Colormap
internAtom Display
d String
"_XROOTPMAP_ID" Bool
False IO Colormap -> (Colormap -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Colormap
xid ->
      let xroot :: Colormap
xroot = Display -> Colormap
defaultRootWindow Display
d in
      (Ptr Colormap -> IO ()) -> IO ()
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr Colormap -> IO ()) -> IO ())
-> (Ptr Colormap -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr Colormap
x1 ->
      (Ptr CInt -> IO ()) -> IO ()
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr CInt -> IO ()) -> IO ()) -> (Ptr CInt -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr CInt
x2 ->
      (Ptr CULong -> IO ()) -> IO ()
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr CULong -> IO ()) -> IO ()) -> (Ptr CULong -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr CULong
x3 ->
      (Ptr CULong -> IO ()) -> IO ()
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr CULong -> IO ()) -> IO ()) -> (Ptr CULong -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr CULong
x4 ->
      (Ptr (Ptr CUChar) -> IO ()) -> IO ()
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr (Ptr CUChar) -> IO ()) -> IO ())
-> (Ptr (Ptr CUChar) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr (Ptr CUChar)
pprop -> do
        Display
-> Colormap
-> Colormap
-> CLong
-> CLong
-> Bool
-> Colormap
-> Ptr Colormap
-> Ptr CInt
-> Ptr CULong
-> Ptr CULong
-> Ptr (Ptr CUChar)
-> IO CInt
xGetWindowProperty Display
d Colormap
xroot Colormap
xid CLong
0 CLong
1 Bool
False Colormap
20 Ptr Colormap
x1 Ptr CInt
x2 Ptr CULong
x3 Ptr CULong
x4 Ptr (Ptr CUChar)
pprop
        Ptr CUChar
prop <- Ptr (Ptr CUChar) -> IO (Ptr CUChar)
forall a. Storable a => Ptr a -> IO a
peek Ptr (Ptr CUChar)
pprop
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Ptr CUChar
prop Ptr CUChar -> Ptr CUChar -> Bool
forall a. Eq a => a -> a -> Bool
/= Ptr CUChar
forall a. Ptr a
nullPtr) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
          Colormap
rootbg <- Ptr Colormap -> IO Colormap
forall a. Storable a => Ptr a -> IO a
peek (Ptr CUChar -> Ptr Colormap
forall a b. Ptr a -> Ptr b
castPtr Ptr CUChar
prop) :: IO Pixmap
          Ptr CUChar -> IO CInt
forall a. Ptr a -> IO CInt
xFree Ptr CUChar
prop
          Display -> Colormap -> (Colormap -> IO ()) -> IO ()
forall a. Display -> Colormap -> (Colormap -> IO a) -> IO ()
withRenderPicture Display
d Colormap
rootbg ((Colormap -> IO ()) -> IO ()) -> (Colormap -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Colormap
bgpic ->
            Display -> XRenderColor -> (Colormap -> IO ()) -> IO ()
forall a. Display -> XRenderColor -> (Colormap -> IO a) -> IO ()
withRenderFill Display
d (Int -> Int -> Int -> Int -> XRenderColor
XRenderColor Int
0 Int
0 Int
0 (Int
0xFFFF Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
257 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
alpha))
                           (CInt -> Colormap -> Colormap -> Colormap -> IO ()
render CInt
pictOpAdd Colormap
bgpic Colormap
pic)

-- | Parses color into XRender color (allocation not necessary!)
parseRenderColor :: Display -> String -> IO XRenderColor
parseRenderColor :: Display -> String -> IO XRenderColor
parseRenderColor Display
d String
c = do
    let colormap :: Colormap
colormap = Display -> ScreenNumber -> Colormap
defaultColormap Display
d (Display -> ScreenNumber
defaultScreen Display
d)
    Color Colormap
_ Word16
red Word16
green Word16
blue Word8
_ <- Display -> Colormap -> String -> IO Color
parseColor Display
d Colormap
colormap String
c
    XRenderColor -> IO XRenderColor
forall (m :: * -> *) a. Monad m => a -> m a
return (XRenderColor -> IO XRenderColor)
-> XRenderColor -> IO XRenderColor
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Int -> Int -> XRenderColor
XRenderColor (Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
red) (Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
green) (Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
blue) Int
0xFFFF

pictOpSrc, pictOpAdd :: PictOp
pictOpSrc :: CInt
pictOpSrc = CInt
1
pictOpAdd :: CInt
pictOpAdd = CInt
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