{-# 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 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 ()

-- Font handling

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
-- 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 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

-- 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 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
    -- Split string and determine fonts for individual parts
    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
        -- 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 _ [] _ = [(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)] -- Last font, use it
    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)] -- Current font can render this substring
    getFont d :: Display
d (_:fs :: [AXftFont]
fs) (False, s :: 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 (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

    -- Determine coordinates for chunks using extents
    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 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 _ = (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" #-}

-- | 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 d :: Display
d p :: Colormap
p f :: Colormap -> IO a
f = do
    Ptr XRenderPictFormat
format <- Display -> CInt -> IO (Ptr XRenderPictFormat)
xRenderFindStandardFormat Display
d 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
$ \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

-- | 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 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

-- | 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 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
    -- 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
$ \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)
    -- Handle transparency
    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)

-- | Parses color into XRender color (allocation not necessary!)
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

-- 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