{-# LINE 1 "Graphics/X11/Xft.hsc" #-}
{-# LANGUAGE ForeignFunctionInterface #-}

-----------------------------------------------------------------------------
-- Module      :  Graphics.X11.Xft
-- Copyright   :  Clemens Fruhwirth <clemens@endorphin.org> 2007
--
-- Haskell bindings for the Xft library.
--
-----------------------------------------------------------------------------

module Graphics.X11.Xft ( XftColor
                        , xftcolor_pixel
                        , allocaXftColor
                        , withXftColorName
                        , withXftColorValue
                        , XftDraw
                        , withXftDraw
                        , xftDrawCreate
                        , xftDrawCreateBitmap
                        , xftDrawCreateAlpha
                        , xftDrawChange
                        , xftDrawDisplay
                        , xftDrawDrawable
                        , xftDrawColormap
                        , xftDrawVisual
                        , xftDrawDestroy
                        , XftFont
                        , xftfont_ascent
                        , xftfont_max_ascent
                        , xftfont_descent
                        , xftfont_max_descent
                        , xftfont_height
                        , xftfont_max_height
                        , xftfont_max_advance_width
                        , xftFontOpen
                        , xftFontOpenXlfd
                        , xftLockFace
                        , xftUnlockFace
                        , xftFontCopy
                        , xftFontClose
                        , xftDrawGlyphs
                        , xftDrawString
                        , xftDrawStringFallback
                        , xftTextExtents
                        , xftTextAccumExtents
                        , xftDrawRect
                        , xftDrawSetClipRectangles
                        , xftDrawSetSubwindowMode
                        , xftInitFtLibrary
                        )
 where

import Graphics.X11
import Graphics.X11.Xlib.Types
import Graphics.X11.Xrender

import Codec.Binary.UTF8.String as UTF8
import Control.Arrow ((&&&))
import Control.Monad (void)
import Data.Char (ord)
import Data.Function (on)
import Data.List (foldl')
import Data.List.NonEmpty (NonEmpty)
import qualified Data.List.NonEmpty as NonEmpty
import Foreign hiding (void)
import Foreign.C.String
import Foreign.C.Types



-----------------------
-- Color Handling    --
-----------------------

newtype XftColor = XftColor (Ptr XftColor)

xftcolor_pixel :: XftColor -> IO Int
xftcolor_pixel :: XftColor -> IO Int
xftcolor_pixel (XftColor Ptr XftColor
p) = forall a. Ptr a -> CInt -> IO Int
peekCUShort Ptr XftColor
p (CInt
0)
{-# LINE 79 "Graphics/X11/Xft.hsc" #-}
-- missing xftcolor_color to get XRenderColor

foreign import ccall "XftColorAllocName"
    cXftColorAllocName :: Display -> Visual -> Colormap -> CString -> XftColor -> IO (Int32)
{-# LINE 83 "Graphics/X11/Xft.hsc" #-}

allocaXftColor :: (Ptr XftColor -> IO a) -> IO a
allocaXftColor :: forall a. (Ptr XftColor -> IO a) -> IO a
allocaXftColor = forall a b. Int -> (Ptr a -> IO b) -> IO b
allocaBytes ((Int
16))
{-# LINE 86 "Graphics/X11/Xft.hsc" #-}

withXftColorName :: Display -> Visual -> Colormap -> String -> (XftColor -> IO a) -> IO a
withXftColorName :: forall a.
Display
-> Visual -> Colormap -> String -> (XftColor -> IO a) -> IO a
withXftColorName Display
d Visual
v Colormap
cm String
name XftColor -> IO a
f =
    forall a. (Ptr XftColor -> IO a) -> IO a
allocaXftColor forall a b. (a -> b) -> a -> b
$ (\XftColor
color -> do
                        forall a. String -> (CString -> IO a) -> IO a
withCAString String
name (\CString
cstring -> do
                                             forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ Display -> Visual -> Colormap -> CString -> XftColor -> IO Int32
cXftColorAllocName Display
d Visual
v Colormap
cm CString
cstring XftColor
color
                                             a
r <- XftColor -> IO a
f XftColor
color
                                             Display -> Visual -> Colormap -> XftColor -> IO ()
cXftColorFree Display
d Visual
v Colormap
cm XftColor
color
                                             forall (m :: * -> *) a. Monad m => a -> m a
return a
r)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ptr XftColor -> XftColor
XftColor

foreign import ccall "XftColorAllocValue"
  cXftColorAllocValue :: Display -> Visual -> Colormap -> (Ptr XRenderColor) -> XftColor -> IO (Int32)
{-# LINE 98 "Graphics/X11/Xft.hsc" #-}

withXftColorValue :: Display -> Visual -> Colormap -> XRenderColor -> (XftColor -> IO a) -> IO a
withXftColorValue :: forall a.
Display
-> Visual -> Colormap -> XRenderColor -> (XftColor -> IO a) -> IO a
withXftColorValue Display
d Visual
v Colormap
cm XRenderColor
rc XftColor -> IO a
f =
    forall a. (Ptr XftColor -> IO a) -> IO a
allocaXftColor forall a b. (a -> b) -> a -> b
$ (\XftColor
color -> do
                        forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b
with XRenderColor
rc (\Ptr XRenderColor
rc_ptr -> do
                                   forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ Display
-> Visual -> Colormap -> Ptr XRenderColor -> XftColor -> IO Int32
cXftColorAllocValue Display
d Visual
v Colormap
cm Ptr XRenderColor
rc_ptr XftColor
color
                                   a
r <- XftColor -> IO a
f XftColor
color
                                   Display -> Visual -> Colormap -> XftColor -> IO ()
cXftColorFree Display
d Visual
v Colormap
cm XftColor
color
                                   forall (m :: * -> *) a. Monad m => a -> m a
return a
r)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ptr XftColor -> XftColor
XftColor

foreign import ccall "XftColorFree"
  cXftColorFree :: Display -> Visual -> Colormap -> XftColor -> IO ()

-----------------------
-- Draw Handling    --
-----------------------

newtype XftDraw = XftDraw (Ptr XftDraw)

withXftDraw :: Display -> Drawable -> Visual -> Colormap -> (XftDraw -> IO a) -> IO a
withXftDraw :: forall a.
Display
-> Colormap -> Visual -> Colormap -> (XftDraw -> IO a) -> IO a
withXftDraw Display
d Colormap
p Visual
v Colormap
c XftDraw -> IO a
act =
    do
      XftDraw
draw <- Display -> Colormap -> Visual -> Colormap -> IO XftDraw
xftDrawCreate Display
d Colormap
p Visual
v Colormap
c
      a
a <- XftDraw -> IO a
act XftDraw
draw
      XftDraw -> IO ()
xftDrawDestroy XftDraw
draw
      forall (m :: * -> *) a. Monad m => a -> m a
return a
a

foreign import ccall "XftDrawCreate"
  xftDrawCreate :: Display -> Drawable -> Visual -> Colormap -> IO XftDraw

foreign import ccall "XftDrawCreateBitmap"
  xftDrawCreateBitmap :: Display -> Pixmap -> IO XftDraw

foreign import ccall "XftDrawCreateAlpha"
  cXftDrawCreateAlpha :: Display -> Pixmap -> CInt -> IO XftDraw

xftDrawCreateAlpha :: Integral a => Display -> Pixmap -> a -> IO XftDraw
xftDrawCreateAlpha :: forall a. Integral a => Display -> Colormap -> a -> IO XftDraw
xftDrawCreateAlpha Display
d Colormap
p a
i = Display -> Colormap -> CInt -> IO XftDraw
cXftDrawCreateAlpha Display
d Colormap
p (forall a b. (Integral a, Num b) => a -> b
fi a
i)

foreign import ccall "XftDrawChange"
  xftDrawChange :: XftDraw -> Drawable -> IO ()

foreign import ccall "XftDrawDisplay"
  xftDrawDisplay :: XftDraw -> IO Display -- FIXME correct? Is X11 giving us the underlying Display?

foreign import ccall "XftDrawDrawable"
  xftDrawDrawable :: XftDraw -> IO Drawable

foreign import ccall "XftDrawColormap"
  xftDrawColormap :: XftDraw -> IO Colormap

foreign import ccall "XftDrawVisual"
  xftDrawVisual :: XftDraw -> IO Visual

foreign import ccall "XftDrawDestroy"
  xftDrawDestroy :: XftDraw -> IO ()

--------------------
-- Font handling  --
--------------------

newtype XftFont = XftFont (Ptr XftFont)

xftfont_ascent, xftfont_descent, xftfont_height, xftfont_max_advance_width :: XftFont -> IO Int
xftfont_ascent :: XftFont -> IO Int
xftfont_ascent (XftFont Ptr XftFont
p)            = forall a. Ptr a -> CInt -> IO Int
peekCUShort Ptr XftFont
p (CInt
0)
{-# LINE 163 "Graphics/X11/Xft.hsc" #-}
xftfont_descent (XftFont p)           = peekCUShort p (4)
{-# LINE 164 "Graphics/X11/Xft.hsc" #-}
xftfont_height (XftFont p)            = peekCUShort p (8)
{-# LINE 165 "Graphics/X11/Xft.hsc" #-}
xftfont_max_advance_width (XftFont p) = peekCUShort p (12)
{-# LINE 166 "Graphics/X11/Xft.hsc" #-}
-- missing xftfont_charset
-- missing xftfont_pattern

foreign import ccall "XftFontOpenName"
  cXftFontOpen :: Display -> CInt -> CString -> IO XftFont

xftFontOpen :: Display -> Screen -> String -> IO XftFont
xftFontOpen :: Display -> Screen -> String -> IO XftFont
xftFontOpen Display
dpy Screen
screen String
fontname =
    forall a. String -> (CString -> IO a) -> IO a
withCAString String
fontname forall a b. (a -> b) -> a -> b
$
      \CString
cfontname -> Display -> CInt -> CString -> IO XftFont
cXftFontOpen Display
dpy (forall a b. (Integral a, Num b) => a -> b
fi (Screen -> Word32
screenNumberOfScreen Screen
screen)) CString
cfontname

foreign import ccall "XftFontOpenXlfd"
  cXftFontOpenXlfd :: Display -> CInt -> CString -> IO XftFont

xftFontOpenXlfd :: Display -> Screen -> String -> IO XftFont
xftFontOpenXlfd :: Display -> Screen -> String -> IO XftFont
xftFontOpenXlfd Display
dpy Screen
screen String
fontname =
    forall a. String -> (CString -> IO a) -> IO a
withCAString String
fontname forall a b. (a -> b) -> a -> b
$ \CString
cfontname -> Display -> CInt -> CString -> IO XftFont
cXftFontOpenXlfd Display
dpy (forall a b. (Integral a, Num b) => a -> b
fi (Screen -> Word32
screenNumberOfScreen Screen
screen)) CString
cfontname

foreign import ccall "XftLockFace"
  xftLockFace :: XftFont -> IO ()                  -- FIXME XftLockFace returns FT_face not void

foreign import ccall "XftUnlockFace"
  xftUnlockFace :: XftFont -> IO ()

foreign import ccall "XftFontCopy"
  xftFontCopy :: Display -> XftFont -> IO XftFont

foreign import ccall "XftFontClose"
  xftFontClose :: Display -> XftFont -> IO ()

-- Support for multiple fonts --

xftfont_max_ascent :: NonEmpty XftFont -> IO Int
xftfont_max_ascent :: NonEmpty XftFont -> IO Int
xftfont_max_ascent = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM XftFont -> IO Int
xftfont_ascent

xftfont_max_descent :: NonEmpty XftFont -> IO Int
xftfont_max_descent :: NonEmpty XftFont -> IO Int
xftfont_max_descent = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM XftFont -> IO Int
xftfont_descent

xftfont_max_height :: NonEmpty XftFont -> IO Int
xftfont_max_height :: NonEmpty XftFont -> IO Int
xftfont_max_height = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM XftFont -> IO Int
xftfont_height

---------------------
-- Painting
---------------------

-- Drawing strings or glyphs --

foreign import ccall "XftCharExists"
  cXftCharExists :: Display -> XftFont -> (Word32) -> IO (Int32)
{-# LINE 215 "Graphics/X11/Xft.hsc" #-}

xftCharExists :: Display -> XftFont -> Char -> IO Bool
xftCharExists :: Display -> XftFont -> Char -> IO Bool
xftCharExists Display
d XftFont
f Char
c = forall {a}. (Eq a, Num a) => a -> Bool
bool forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Display -> XftFont -> Word32 -> IO Int32
cXftCharExists Display
d XftFont
f (forall a b. (Integral a, Num b) => a -> b
fi 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

foreign import ccall "XftDrawGlyphs"
  cXftDrawGlyphs :: XftDraw -> XftColor -> XftFont -> CInt -> CInt -> Ptr (Word32) -> CInt -> IO ()
{-# LINE 224 "Graphics/X11/Xft.hsc" #-}

xftDrawGlyphs :: (Integral a, Integral b, Integral c)
              => XftDraw -> XftColor -> XftFont -> b -> c -> [a] -> IO ()
xftDrawGlyphs :: forall a b c.
(Integral a, Integral b, Integral c) =>
XftDraw -> XftColor -> XftFont -> b -> c -> [a] -> IO ()
xftDrawGlyphs XftDraw
d XftColor
c XftFont
f b
x c
y [a]
glyphs =
    forall a b. Storable a => [a] -> (Int -> Ptr a -> IO b) -> IO b
withArrayLen (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (Integral a, Num b) => a -> b
fi [a]
glyphs)
      (\Int
len Ptr Word32
ptr -> XftDraw
-> XftColor
-> XftFont
-> CInt
-> CInt
-> Ptr Word32
-> CInt
-> IO ()
cXftDrawGlyphs XftDraw
d XftColor
c XftFont
f (forall a b. (Integral a, Num b) => a -> b
fi b
x) (forall a b. (Integral a, Num b) => a -> b
fi c
y) Ptr Word32
ptr (forall a b. (Integral a, Num b) => a -> b
fi Int
len))

foreign import ccall "XftDrawStringUtf8"
  cXftDrawStringUtf8 :: XftDraw -> XftColor -> XftFont -> CInt -> CInt -> Ptr (Word8) -> CInt -> IO ()
{-# LINE 233 "Graphics/X11/Xft.hsc" #-}

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

-- Querying text extends for strings or glyphs --

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

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

-- Support for multiple fonts --

-- | Like 'xftDrawString', but fall back to another font in the given
-- list if necessary (i.e., should a character not be drawable with the
-- currently selected font).
xftDrawStringFallback :: XftDraw -> XftColor -> [XftFont] -> Int -> Int -> String -> IO ()
xftDrawStringFallback :: XftDraw -> XftColor -> [XftFont] -> Int -> Int -> String -> IO ()
xftDrawStringFallback XftDraw
d XftColor
c [XftFont]
fs Int
x Int
y String
string = do
    Display
display <- XftDraw -> IO Display
xftDrawDisplay XftDraw
d
    [(XftFont, String, XGlyphInfo)]
chunks <- Display
-> [XftFont]
-> Int
-> Int
-> String
-> IO [(XftFont, String, XGlyphInfo)]
getChunks Display
display [XftFont]
fs Int
x Int
y String
string
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\(XftFont
f, String
s, (XGlyphInfo Int
_  Int
_ Int
x' Int
y' Int
_ Int
_)) -> forall a b.
(Integral a, Integral b) =>
XftDraw -> XftColor -> XftFont -> a -> b -> String -> IO ()
xftDrawString XftDraw
d XftColor
c XftFont
f Int
x' Int
y' String
s) [(XftFont, String, XGlyphInfo)]
chunks

-- | Like 'xftTextExtents' but for multiple fonts. Return
-- accumulative extents using appropriate fonts for each part of
-- string.
xftTextAccumExtents :: Display -> [XftFont] -> String -> IO XGlyphInfo
xftTextAccumExtents :: Display -> [XftFont] -> String -> IO XGlyphInfo
xftTextAccumExtents Display
disp [XftFont]
fts String
string = do
  [XGlyphInfo]
chunks <- forall a b. (a -> b) -> [a] -> [b]
map (\ (XftFont
_, String
_, XGlyphInfo
gi) -> XGlyphInfo
gi) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Display
-> [XftFont]
-> Int
-> Int
-> String
-> IO [(XftFont, String, XGlyphInfo)]
getChunks Display
disp [XftFont]
fts Int
0 Int
0 String
string
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' XGlyphInfo -> XGlyphInfo -> XGlyphInfo
calcExtents (Int -> Int -> Int -> Int -> Int -> Int -> XGlyphInfo
XGlyphInfo Int
0 Int
0 Int
0 Int
0 Int
0 Int
0) [XGlyphInfo]
chunks
  where
    calcExtents :: XGlyphInfo -> XGlyphInfo -> XGlyphInfo
    calcExtents :: XGlyphInfo -> XGlyphInfo -> XGlyphInfo
calcExtents (XGlyphInfo Int
_ Int
_ Int
x Int
y Int
xo Int
yo) (XGlyphInfo Int
w' Int
h' Int
_ Int
_ Int
xo' Int
yo')
      = Int -> Int -> Int -> Int -> Int -> Int -> XGlyphInfo
XGlyphInfo (Int
xo forall a. Num a => a -> a -> a
+ Int
w') (Int
yo forall a. Num a => a -> a -> a
+ Int
h') Int
x Int
y (Int
xo forall a. Num a => a -> a -> a
+ Int
xo') (Int
yo forall a. Num a => a -> a -> a
+ Int
yo')

-- | Split string and determine fonts/offsets for individual parts
getChunks :: Display
          -> [XftFont]
          -> Int
          -> Int
          -> String
          -> IO [(XftFont, String, XGlyphInfo)]
getChunks :: Display
-> [XftFont]
-> Int
-> Int
-> String
-> IO [(XftFont, String, XGlyphInfo)]
getChunks Display
disp [XftFont]
fts Int
xInit Int
yInit String
str = do
    [(XftFont, String)]
chunks <- [XftFont] -> String -> IO [(XftFont, String)]
getFonts [XftFont]
fts String
str
    Int
-> Int -> [(XftFont, String)] -> IO [(XftFont, String, XGlyphInfo)]
getChunksExtents Int
xInit Int
yInit [(XftFont, String)]
chunks
  where
    -- Split string and determine fonts for individual parts
    getFonts :: [XftFont] -> String -> IO [(XftFont, String)]
    getFonts :: [XftFont] -> String -> IO [(XftFont, String)]
getFonts [] String
_ = forall (m :: * -> *) a. Monad m => a -> m a
return []
    getFonts [XftFont
ft] String
s = forall (m :: * -> *) a. Monad m => a -> m a
return [(XftFont
ft, String
s)]
    getFonts fonts :: [XftFont]
fonts@(XftFont
ft:[XftFont]
_) String
s = do
        -- Determine which glyph can be rendered by current font
        [Bool]
glyphs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Display -> XftFont -> Char -> IO Bool
xftCharExists Display
disp XftFont
ft) String
s
        -- Split string into parts that return "can/cannot be rendered"
        let splits :: [(Bool, String)]
splits = forall a b. (a -> b) -> [a] -> [b]
map (forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. NonEmpty a -> a
NonEmpty.head forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. NonEmpty a -> [a]
NonEmpty.toList)
                   forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall (f :: * -> *) a.
Foldable f =>
(a -> a -> Bool) -> f a -> [NonEmpty a]
NonEmpty.groupBy (forall a. Eq a => a -> a -> Bool
(==) forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` forall a b. (a, b) -> a
fst))
                   forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
zip [Bool]
glyphs String
s
        -- Determine which font to render each chunk with
        forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ([XftFont] -> (Bool, String) -> IO [(XftFont, String)]
getFont [XftFont]
fonts) [(Bool, String)]
splits

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

    -- Determine coordinates for chunks using extents
    getChunksExtents :: Int -> Int -> [(XftFont, String)] -> IO [(XftFont, String, XGlyphInfo)]
    getChunksExtents :: Int
-> Int -> [(XftFont, String)] -> IO [(XftFont, String, XGlyphInfo)]
getChunksExtents Int
_ Int
_ [] = forall (m :: * -> *) a. Monad m => a -> m a
return []
    getChunksExtents Int
x Int
y ((XftFont
f, String
s) : [(XftFont, String)]
chunks) = do
      (XGlyphInfo Int
w Int
h Int
_ Int
_ Int
xo Int
yo) <- Display -> XftFont -> String -> IO XGlyphInfo
xftTextExtents Display
disp XftFont
f String
s
      [(XftFont, String, XGlyphInfo)]
rest <- Int
-> Int -> [(XftFont, String)] -> IO [(XftFont, String, XGlyphInfo)]
getChunksExtents (Int
x forall a. Num a => a -> a -> a
+ Int
xo) (Int
y forall a. Num a => a -> a -> a
+ Int
yo) [(XftFont, String)]
chunks
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ (XftFont
f, String
s, Int -> Int -> Int -> Int -> Int -> Int -> XGlyphInfo
XGlyphInfo Int
w Int
h Int
x Int
y Int
xo Int
yo) forall a. a -> [a] -> [a]
: [(XftFont, String, XGlyphInfo)]
rest

-- Drawing auxilary --

foreign import ccall "XftDrawRect"
  cXftDrawRect :: XftDraw -> XftColor -> CInt -> CInt -> CUInt -> CUInt -> IO ()

xftDrawRect :: (Integral a, Integral b, Integral c, Integral d)
            => XftDraw -> XftColor -> a -> b -> c -> d -> IO ()
xftDrawRect :: forall a b c d.
(Integral a, Integral b, Integral c, Integral d) =>
XftDraw -> XftColor -> a -> b -> c -> d -> IO ()
xftDrawRect XftDraw
draw XftColor
color a
x b
y c
width d
height =
    XftDraw -> XftColor -> CInt -> CInt -> CUInt -> CUInt -> IO ()
cXftDrawRect XftDraw
draw XftColor
color (forall a b. (Integral a, Num b) => a -> b
fi a
x) (forall a b. (Integral a, Num b) => a -> b
fi b
y) (forall a b. (Integral a, Num b) => a -> b
fi c
width) (forall a b. (Integral a, Num b) => a -> b
fi d
height)

foreign import ccall "XftDrawSetClip"
    cXftDrawSetClip :: XftDraw -> Ptr Region -> IO (Int32)
{-# LINE 328 "Graphics/X11/Xft.hsc" #-}

--xftDrawSetClip d (Region r) =
--    do
--      rv <- cXftDrawSetClip d r
--      return $ (fi rv) /= 0

foreign import ccall "XftDrawSetClipRectangles"
  cXftDrawSetClipRectangles :: XftDraw -> CInt -> CInt -> (Ptr Rectangle) -> CInt -> IO CInt

xftDrawSetClipRectangles :: XftDraw -> Int -> Int -> [Rectangle] -> IO Bool
xftDrawSetClipRectangles :: XftDraw -> Int -> Int -> [Rectangle] -> IO Bool
xftDrawSetClipRectangles XftDraw
draw Int
x Int
y [Rectangle]
rectangles =
    forall a b. Storable a => [a] -> (Int -> Ptr a -> IO b) -> IO b
withArrayLen [Rectangle]
rectangles
      (\Int
len Ptr Rectangle
rects -> do
         CInt
r <- XftDraw -> CInt -> CInt -> Ptr Rectangle -> CInt -> IO CInt
cXftDrawSetClipRectangles XftDraw
draw (forall a b. (Integral a, Num b) => a -> b
fi Int
x) (forall a b. (Integral a, Num b) => a -> b
fi Int
y) Ptr Rectangle
rects (forall a b. (Integral a, Num b) => a -> b
fi Int
len)
         forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Integral a => a -> Integer
toInteger CInt
r forall a. Eq a => a -> a -> Bool
/= Integer
0)) -- verify whether this is really the convention

foreign import ccall "XftDrawSetSubwindowMode"
  cXftDrawSetSubwindowMode :: XftDraw -> CInt -> IO ()

xftDrawSetSubwindowMode :: Integral a => XftDraw -> a -> IO ()
xftDrawSetSubwindowMode :: forall a. Integral a => XftDraw -> a -> IO ()
xftDrawSetSubwindowMode XftDraw
d a
i = XftDraw -> CInt -> IO ()
cXftDrawSetSubwindowMode XftDraw
d (forall a b. (Integral a, Num b) => a -> b
fi a
i)

--------------
-- Auxillary
--------------

foreign import ccall "XftInitFtLibrary"
  xftInitFtLibrary :: IO ()

{-
These functions minimize round-trip between the library and the using program (maybe also to the X server?)
but otherwise all the functions can be achieved by DrawGlyphs

void
XftDrawCharSpec (XftDraw                *draw,
                 _Xconst XftColor       *color,
                 XftFont                *pub,
                 _Xconst XftCharSpec    *chars,
                 int                    len);

void
XftDrawCharFontSpec (XftDraw                    *draw,
                     _Xconst XftColor           *color,
                     _Xconst XftCharFontSpec    *chars,
                     int                        len);

void
XftDrawGlyphSpec (XftDraw               *draw,
                  _Xconst XftColor      *color,
                  XftFont               *pub,
                  _Xconst XftGlyphSpec  *glyphs,
                  int                   len);

void
XftDrawGlyphFontSpec (XftDraw                   *draw,
                      _Xconst XftColor          *color,
                      _Xconst XftGlyphFontSpec  *glyphs,
                      int                       len);
------
Missing
void
XftGlyphExtents (Display            *dpy,
                 XftFont            *pub,
                 _Xconst FT_UInt    *glyphs,
                 int                nglyphs,
                 XGlyphInfo         *extents);

Intentionally Missing Bindings
xftDrawString8,xftDrawString16,xftDrawString32,xftDrawStringUtf16


--foreign import ccall "XftDrawSetClip"
-- cXftDrawSetClip :: XftDraw -> Ptr (??) Region -> IO (#type Bool)


Missing Bindings because of missing Freetype bindings

/* xftfreetype.c */

XftFontInfo *
XftFontInfoCreate (Display *dpy, _Xconst FcPattern *pattern);

void
XftFontInfoDestroy (Display *dpy, XftFontInfo *fi);

FcChar32
XftFontInfoHash (_Xconst XftFontInfo *fi);

FcBool
XftFontInfoEqual (_Xconst XftFontInfo *a, _Xconst XftFontInfo *b);

XftFont *
XftFontOpenInfo (Display        *dpy,
                 FcPattern      *pattern,
                 XftFontInfo    *fi);

XftFont *
XftFontOpenPattern (Display *dpy, FcPattern *pattern);

-- no Render bindings yet
--foreign import ccall "XftDrawPicture"
--  cXftDrawPicture :: XftDraw -> IO Picture
--foreign import ccall "XftDrawPicture"
--  cXftDrawSrcPicture :: XftDraw -> XftColor -> IO Picture
-}

-- | Short-hand for 'fromIntegral'
fi :: (Integral a, Num b) => a -> b
fi :: forall a b. (Integral a, Num b) => a -> b
fi = forall a b. (Integral a, Num b) => a -> b
fromIntegral