{-# 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 d :: Display
d v :: Visual
v cm :: Colormap
cm n :: String
n = do
Ptr AXftColor
color <- Int -> IO (Ptr AXftColor)
forall a. Int -> IO (Ptr a)
mallocBytes ((12))
{-# 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 p :: Ptr AXftFont
p) = Ptr AXftFont -> CInt -> IO Int
forall a. Ptr a -> CInt -> IO Int
peekCUShort Ptr AXftFont
p (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 p :: Ptr AXftFont
p) = Ptr AXftFont -> CInt -> IO Int
forall a. Ptr a -> CInt -> IO Int
peekCUShort Ptr AXftFont
p (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 p :: Ptr AXftFont
p) = Ptr AXftFont -> CInt -> IO Int
forall a. Ptr a -> CInt -> IO Int
peekCUShort Ptr AXftFont
p (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 d :: Display
d f :: AXftFont
f string :: 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
$
\len :: Int
len str_ptr :: 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
$
\cglyph :: 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' d :: Display
d fs :: [AXftFont]
fs string :: 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 (_, _, gi :: XGlyphInfo
gi, _, _) = [(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 dpy :: Display
dpy screen :: Screen
screen name :: 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
$
\cname :: CString
cname -> Display -> CInt -> CString -> IO AXftFont
c_xftFontOpen Display
dpy (Colormap -> CInt
forall a b. (Integral a, Num b) => a -> b
fi (Screen -> Colormap
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 d :: Display
d f :: AXftFont
f c :: 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 -> Colormap -> IO Int32
cXftCharExists Display
d AXftFont
f (Int -> Colormap
forall a b. (Integral a, Num b) => a -> b
fi (Int -> Colormap) -> Int -> Colormap
forall a b. (a -> b) -> a -> b
$ Char -> Int
ord Char
c)
where
bool :: a -> Bool
bool 0 = Bool
False
bool _ = 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 d :: Display
d p :: Colormap
p v :: Visual
v c :: Colormap
c act :: 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 d :: AXftDraw
d c :: AXftColor
c f :: AXftFont
f x :: a
x y :: a1
y string :: 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))
(\len :: Int
len ptr :: 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' d :: AXftDraw
d c :: AXftColor
c fs :: [AXftFont]
fs x :: Integer
x y :: Integer
y string :: 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_ (\(f :: AXftFont
f, s :: String
s, _, xo :: Integer
xo, yo :: 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 disp :: Display
disp fts :: [AXftFont]
fts str :: 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 0 0 0 0 0 0) [(AXftFont, String)]
chunks
where
getFonts :: Display -> [AXftFont] -> String -> IO [(AXftFont, String)]
getFonts _ [] _ = [(AXftFont, String)] -> IO [(AXftFont, String)]
forall (m :: * -> *) a. Monad m => a -> m a
return []
getFonts _ _ [] = [(AXftFont, String)] -> IO [(AXftFont, String)]
forall (m :: * -> *) a. Monad m => a -> m a
return []
getFonts _ [ft :: AXftFont
ft] s :: String
s = [(AXftFont, String)] -> IO [(AXftFont, String)]
forall (m :: * -> *) a. Monad m => a -> m a
return [(AXftFont
ft, String
s)]
getFonts d :: Display
d fonts :: [AXftFont]
fonts@(ft :: AXftFont
ft:_) s :: 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 _ [] _ = [(AXftFont, String)] -> IO [(AXftFont, String)]
forall (m :: * -> *) a. Monad m => a -> m a
return []
getFont _ [ft :: AXftFont
ft] (_, s :: String
s) = [(AXftFont, String)] -> IO [(AXftFont, String)]
forall (m :: * -> *) a. Monad m => a -> m a
return [(AXftFont
ft, String
s)]
getFont _ (ft :: AXftFont
ft:_) (True, s :: String
s) = [(AXftFont, String)] -> IO [(AXftFont, String)]
forall (m :: * -> *) a. Monad m => a -> m a
return [(AXftFont
ft, String
s)]
getFont d :: Display
d (_:fs :: [AXftFont]
fs) (False, s :: String
s) = Display -> [AXftFont] -> String -> IO [(AXftFont, String)]
getFonts Display
d [AXftFont]
fs String
s
runs :: [a] -> [(a, Int)]
runs [] = []
runs (x :: a
x:xs :: [a]
xs) = let (h :: [a]
h, t :: [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
+ 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 [] _ = []
split ((x :: a
x, c :: Int
c):xs :: [(a, Int)]
xs) s :: [a]
s = let (h :: [a]
h, t :: [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 _ [] = [(AXftFont, String, XGlyphInfo, d, e)]
-> IO [(AXftFont, String, XGlyphInfo, d, e)]
forall (m :: * -> *) a. Monad m => a -> m a
return []
getOffsets (XGlyphInfo _ _ x :: Int
x y :: Int
y xo :: Int
xo yo :: Int
yo) ((f :: AXftFont
f, s :: String
s):chunks :: [(AXftFont, String)]
chunks) = do
(XGlyphInfo w' :: Int
w' h' :: Int
h' _ _ xo' :: Int
xo' yo' :: 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 draw :: AXftDraw
draw color :: AXftColor
color x :: a
x y :: a1
y width :: a2
width height :: 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 _ = (52)
{-# LINE 254 "src/Xmobar/X11/MinXft.hsc" #-}
alignment _ = alignment (undefined :: CInt)
peek :: Ptr XRenderPictureAttributes -> IO XRenderPictureAttributes
peek _ = XRenderPictureAttributes -> IO XRenderPictureAttributes
forall (m :: * -> *) a. Monad m => a -> m a
return XRenderPictureAttributes
XRenderPictureAttributes
poke :: Ptr XRenderPictureAttributes -> XRenderPictureAttributes -> IO ()
poke p :: Ptr XRenderPictureAttributes
p XRenderPictureAttributes =
Ptr XRenderPictureAttributes -> CInt -> CSize -> IO ()
forall a. Ptr a -> CInt -> CSize -> IO ()
memset Ptr XRenderPictureAttributes
p 0 (52)
{-# LINE 258 "src/Xmobar/X11/MinXft.hsc" #-}
withRenderPicture :: Display -> Drawable -> (Picture -> IO a) -> IO ()
withRenderPicture :: Display -> Colormap -> (Colormap -> IO a) -> IO ()
withRenderPicture d :: Display
d p :: Colormap
p f :: Colormap -> IO a
f = do
Ptr XRenderPictFormat
format <- Display -> CInt -> IO (Ptr XRenderPictFormat)
xRenderFindStandardFormat Display
d 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
$ \attr :: Ptr XRenderPictureAttributes
attr -> do
Colormap
pic <- Display
-> Colormap
-> Ptr XRenderPictFormat
-> CULong
-> Ptr XRenderPictureAttributes
-> IO Colormap
xRenderCreatePicture Display
d Colormap
p Ptr XRenderPictFormat
format 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 d :: Display
d c :: XRenderColor
c f :: 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 d :: Display
d p :: Colormap
p bgc :: String
bgc alpha :: Int
alpha (Rectangle x :: Int32
x y :: Int32
y wid :: Colormap
wid ht :: Colormap
ht) = do
let render :: CInt -> Colormap -> Colormap -> Colormap -> IO ()
render opt :: CInt
opt bg :: Colormap
bg pic :: Colormap
pic m :: 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) 0 0
0 0 (Colormap -> CUInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Colormap
wid) (Colormap -> CUInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Colormap
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
$ \pic :: 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
$ \bgfill :: Colormap
bgfill ->
Display -> XRenderColor -> (Colormap -> IO ()) -> IO ()
forall a. Display -> XRenderColor -> (Colormap -> IO a) -> IO ()
withRenderFill Display
d
(Int -> Int -> Int -> Int -> XRenderColor
XRenderColor 0 0 0 (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 "_XROOTPMAP_ID" Bool
False IO Colormap -> (Colormap -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \xid :: 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
$ \x1 :: 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
$ \x2 :: 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
$ \x3 :: 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
$ \x4 :: 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
$ \pprop :: 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 0 1 Bool
False 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
$ \bgpic :: Colormap
bgpic ->
Display -> XRenderColor -> (Colormap -> IO ()) -> IO ()
forall a. Display -> XRenderColor -> (Colormap -> IO a) -> IO ()
withRenderFill Display
d (Int -> Int -> Int -> Int -> XRenderColor
XRenderColor 0 0 0 (0xFFFF Int -> Int -> Int
forall a. Num a => a -> a -> a
- 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 d :: Display
d c :: String
c = do
let colormap :: Colormap
colormap = Display -> Colormap -> Colormap
defaultColormap Display
d (Display -> Colormap
defaultScreen Display
d)
Color _ red :: Word16
red green :: Word16
green blue :: Word16
blue _ <- 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) 0xFFFF
pictOpSrc, pictOpAdd :: PictOp
pictOpSrc :: CInt
pictOpSrc = 1
pictOpAdd :: CInt
pictOpAdd = 12