{-# LINE 1 "src/Xmobar/X11/MinXft.hsc" #-}
{-# 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)
newtype AXftColor = AXftColor (Ptr AXftColor)
foreign import ccall "XftColorAllocName"
cXftColorAllocName :: Display -> Visual -> Colormap -> CString -> AXftColor -> IO (Int32)
{-# LINE 68 "src/Xmobar/X11/MinXft.hsc" #-}
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 ()
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
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
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
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
[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
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
[[(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
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)]
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)]
getFont Display
d (AXftFont
_:[AXftFont]
fs) (Bool
False, String
s) = Display -> [AXftFont] -> String -> IO [(AXftFont, String)]
getFonts Display
d [AXftFont]
fs String
s
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
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 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
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" #-}
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
(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
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
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
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)
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)
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