{-# LINE 1 "Graphics/X11/Xft.hsc" #-}
-----------------------------------------------------------------------------
-- 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_descent
			, xftfont_height
			, xftfont_max_advance_width
			, xftFontOpen
			, xftFontOpenXlfd
			, xftLockFace
			, xftUnlockFace
			, xftFontCopy
			, xftFontClose
			, xftDrawGlyphs
			, xftDrawString
			, xftTextExtents
			, xftDrawRect
			, xftDrawSetClipRectangles
			, xftDrawSetSubwindowMode
			, xftInitFtLibrary
 			  )

where
import Graphics.X11
import Graphics.X11.Xlib.Types
import Graphics.X11.Xlib.Region
import Graphics.X11.Xrender

import Foreign
import Foreign.C.Types
import Foreign.C.String
import Foreign.Ptr
import Foreign.Marshal.Alloc
import Foreign.Marshal.Array
import Codec.Binary.UTF8.String as UTF8
import Data.Int
import Data.Word
import Control.Monad



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

newtype XftColor = XftColor (Ptr XftColor)

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

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

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

withXftColorName :: Display -> Visual -> Colormap -> String -> (XftColor -> IO a) -> IO a
withXftColorName :: Display
-> Visual -> Colormap -> String -> (XftColor -> IO a) -> IO a
withXftColorName Display
d Visual
v Colormap
cm String
name XftColor -> IO a
f =
    (Ptr XftColor -> IO a) -> IO a
forall a. (Ptr XftColor -> IO a) -> IO a
allocaXftColor ((Ptr XftColor -> IO a) -> IO a) -> (Ptr XftColor -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ (\XftColor
color -> do
	  		String -> (CString -> IO a) -> IO a
forall a. String -> (CString -> IO a) -> IO a
withCAString String
name (\CString
cstring -> do
					     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
					     a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
r)) (XftColor -> IO a)
-> (Ptr XftColor -> XftColor) -> Ptr XftColor -> IO a
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 90 "Graphics/X11/Xft.hsc" #-}

withXftColorValue :: Display -> Visual -> Colormap -> XRenderColor -> (XftColor -> IO a) -> IO a
withXftColorValue :: Display
-> Visual -> Colormap -> XRenderColor -> (XftColor -> IO a) -> IO a
withXftColorValue Display
d Visual
v Colormap
cm XRenderColor
rc XftColor -> IO a
f =
    (Ptr XftColor -> IO a) -> IO a
forall a. (Ptr XftColor -> IO a) -> IO a
allocaXftColor ((Ptr XftColor -> IO a) -> IO a) -> (Ptr XftColor -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ (\XftColor
color -> do
	  	        XRenderColor -> (Ptr XRenderColor -> IO a) -> IO a
forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b
with XRenderColor
rc (\Ptr XRenderColor
rc_ptr -> do
				   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
				   a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
r)) (XftColor -> IO a)
-> (Ptr XftColor -> XftColor) -> Ptr XftColor -> IO a
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 :: 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
      a -> IO a
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 :: Display -> Colormap -> a -> IO XftDraw
xftDrawCreateAlpha Display
d Colormap
p a
i = Display -> Colormap -> CInt -> IO XftDraw
cXftDrawCreateAlpha Display
d Colormap
p (a -> CInt
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 -> IO Int
xftfont_ascent (XftFont Ptr XftFont
p)            = Ptr XftFont -> CInt -> IO Int
forall a. Ptr a -> CInt -> IO Int
peekCUShort Ptr XftFont
p (CInt
0)
{-# LINE 153 "Graphics/X11/Xft.hsc" #-}
xftfont_descent (XftFont p)           = peekCUShort p (4)
{-# LINE 154 "Graphics/X11/Xft.hsc" #-}
xftfont_height (XftFont p)            = peekCUShort p (8)
{-# LINE 155 "Graphics/X11/Xft.hsc" #-}
xftfont_max_advance_width (XftFont p) = peekCUShort p (12)
{-# LINE 156 "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
dpy Screen
screen String
fontname =
    String -> (CString -> IO XftFont) -> IO XftFont
forall a. String -> (CString -> IO a) -> IO a
withCAString String
fontname ((CString -> IO XftFont) -> IO XftFont)
-> (CString -> IO XftFont) -> IO XftFont
forall a b. (a -> b) -> a -> b
$
      \CString
cfontname -> Display -> CInt -> CString -> IO XftFont
cXftFontOpen Display
dpy (ScreenNumber -> CInt
forall a b. (Integral a, Num b) => a -> b
fi (Screen -> ScreenNumber
screenNumberOfScreen Screen
screen)) CString
cfontname

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

xftFontOpenXlfd :: Display -> Screen -> String -> IO XftFont
xftFontOpenXlfd Display
dpy Screen
screen String
fontname =
    String -> (CString -> IO XftFont) -> IO XftFont
forall a. String -> (CString -> IO a) -> IO a
withCAString String
fontname ((CString -> IO XftFont) -> IO XftFont)
-> (CString -> IO XftFont) -> IO XftFont
forall a b. (a -> b) -> a -> b
$ \CString
cfontname -> Display -> CInt -> CString -> IO XftFont
cXftFontOpenXlfd Display
dpy (ScreenNumber -> CInt
forall a b. (Integral a, Num b) => a -> b
fi (Screen -> ScreenNumber
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 ()

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

-- Drawing strings or glyphs --

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

xftDrawGlyphs :: XftDraw -> XftColor -> XftFont -> a -> a -> [a] -> IO ()
xftDrawGlyphs XftDraw
d XftColor
c XftFont
f a
x a
y [a]
glyphs =
    [ScreenNumber] -> (Int -> Ptr ScreenNumber -> IO ()) -> IO ()
forall a b. Storable a => [a] -> (Int -> Ptr a -> IO b) -> IO b
withArrayLen ((a -> ScreenNumber) -> [a] -> [ScreenNumber]
forall a b. (a -> b) -> [a] -> [b]
map a -> ScreenNumber
forall a b. (Integral a, Num b) => a -> b
fi [a]
glyphs)
      (\Int
len Ptr ScreenNumber
ptr -> XftDraw
-> XftColor
-> XftFont
-> CInt
-> CInt
-> Ptr ScreenNumber
-> CInt
-> IO ()
cXftDrawGlyphs XftDraw
d XftColor
c XftFont
f (a -> CInt
forall a b. (Integral a, Num b) => a -> b
fi a
x) (a -> CInt
forall a b. (Integral a, Num b) => a -> b
fi a
y) Ptr ScreenNumber
ptr (Int -> CInt
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 199 "Graphics/X11/Xft.hsc" #-}

xftDrawString :: XftDraw -> XftColor -> XftFont -> a -> a -> String -> IO ()
xftDrawString XftDraw
d XftColor
c XftFont
f a
x a
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 -> XftDraw
-> XftColor
-> XftFont
-> CInt
-> CInt
-> Ptr Word8
-> CInt
-> IO ()
cXftDrawStringUtf8 XftDraw
d XftColor
c XftFont
f (a -> CInt
forall a b. (Integral a, Num b) => a -> b
fi a
x) (a -> CInt
forall a b. (Integral a, Num b) => a -> b
fi a
y) Ptr Word8
ptr (Int -> CInt
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 =
    [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 -> XftFont -> CString -> CInt -> Ptr XGlyphInfo -> IO ()
cXftTextExtentsUtf8 Display
d XftFont
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

-- Drawing auxilary --

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

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

foreign import ccall "XftDrawSetClip"
    cXftDrawSetClip :: XftDraw -> Ptr Region -> IO (Int32)
{-# LINE 227 "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]
rects =
    [Rectangle] -> (Int -> Ptr Rectangle -> IO Bool) -> IO Bool
forall a b. Storable a => [a] -> (Int -> Ptr a -> IO b) -> IO b
withArrayLen [Rectangle]
rects
      (\Int
len Ptr Rectangle
rects -> do
	 CInt
r <- XftDraw -> CInt -> CInt -> Ptr Rectangle -> CInt -> IO CInt
cXftDrawSetClipRectangles XftDraw
draw (Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fi Int
x) (Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fi Int
y) Ptr Rectangle
rects (Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fi Int
len)
         Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (CInt -> Integer
forall a. Integral a => a -> Integer
toInteger CInt
r Integer -> Integer -> Bool
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 :: XftDraw -> a -> IO ()
xftDrawSetSubwindowMode XftDraw
d a
i = XftDraw -> CInt -> IO ()
cXftDrawSetSubwindowMode XftDraw
d (a -> CInt
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 :: a -> b
fi = a -> b
forall a b. (Integral a, Num b) => a -> b
fromIntegral