X11-xft-0.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
where
import Graphics.X11
import Graphics.X11.Xlib.Types
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 Monad

#include <X11/Xft/Xft.h>

newtype XftFont = XftFont (Ptr XftFont)

newtype XftDraw = XftDraw (Ptr XftDraw)

newtype XftColor = XftColor (Ptr XftColor)

-- xftcolor.c
foreign import ccall "XftColorAllocName"
  cXftColorAllocName :: Display -> Visual -> Colormap -> CString -> XftColor -> IO (#type Bool)

allocaXftColor :: (Ptr XftColor -> IO a) -> IO a
allocaXftColor = allocaBytes (#size XftColor)

withXftColorName :: Display -> Visual -> Colormap -> String -> (XftColor -> IO a) -> IO a
withXftColorName d v cm name f = 
	  allocaXftColor $ (\color -> do  
	  	                withCAString name (\cstring -> do 
						     cXftColorAllocName d v cm cstring color
						     r <- f color
						     cXftColorFree d v cm color
						     return r)) . XftColor

foreign import ccall "XftColorAllocValue"
  cXftColorAllocValue :: Display -> Visual -> Colormap -> (Ptr XRenderColor) -> XftColor -> IO (#type Bool)

withXftColorValue :: Display -> Visual -> Colormap -> XRenderColor -> (XftColor -> IO a) -> IO a
withXftColorValue d v cm rc f = 
    allocaXftColor $ (\color -> do  
	  	        with rc (\rc_ptr -> do 
				   cXftColorAllocValue d v cm rc_ptr color
				   r <- f color
				   cXftColorFree d v cm color
				   return r)) . XftColor

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

-- xftdraw.c 

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 d p i = cXftDrawCreateAlpha d p (fromIntegral i)

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

foreign import ccall "XftDrawDisplay" 
  xftDrawDisplay :: XftDraw -> IO 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 ()

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

foreign import ccall "XftDrawGlyphs"
 cXftDrawGlyphs :: XftDraw -> XftColor -> XftFont -> CInt -> CInt -> Ptr (#type FT_UInt) -> CInt -> IO ()

xftDrawGlyphs d c f x y glyphs =
 withArrayLen ((map fromIntegral glyphs) :: [Word32]) (\len ptr -> cXftDrawGlyphs d c f (fromIntegral x) (fromIntegral y) ptr (fromIntegral len)) 

--foreign import ccall "XftDrawString8"
--  cXftDrawString8 :: XftDraw -> XftColor -> XftFont -> CInt -> CInt -> CString -> CInt -> IO ()
--
--xftDrawString8 :: XftDraw -> XftColor -> XftFont -> Int -> Int -> String -> IO ()
--xftDrawString8 draw color font x y string = 
--    withCAString string $ \cs1 -> cXftDrawString8 draw color font (fromIntegral x) (fromIntegral y) cs1 (fromIntegral (length string))
--
-- We ignore xftDrawString8,xftDrawString16,xftDrawString32,xftDrawStringUtf16
--

foreign import ccall "XftDrawStringUtf8"
  cXftDrawStringUtf8 :: XftDraw -> XftColor -> XftFont -> CInt -> CInt -> Ptr (#type FcChar8) -> CInt -> IO ()

xftDrawString d c f x y string =
    withArrayLen (map fromIntegral (UTF8.encode string))
		     (\len ptr -> cXftDrawStringUtf8 d c f (fromIntegral x) (fromIntegral y) ptr (fromIntegral len))

{-
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);

-}

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

xftDrawRect draw color x y width height =
 cXftDrawRect draw color (fromInteger x) (fromInteger y) (fromInteger width) (fromInteger height)


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

{-

Bool
XftDrawSetClipRectangles (XftDraw		*draw,
			  int			xOrigin,
			  int			yOrigin,
			  _Xconst XRectangle	*rects,
			  int			n);
-}

foreign import ccall "XftDrawSetClip"
 xftDrawSetSubwindowMode :: XftDraw -> CInt -> IO ()
{-
Missing XRender Bindings
EXTEND START
void
XftGlyphExtents (Display	    *dpy,
		 XftFont	    *pub,
		 _Xconst FT_UInt    *glyphs,
		 int		    nglyphs,
		 XGlyphInfo	    *extents);
-}
foreign import ccall "XftTextExtentsUtf8"
  cXftTextExtentsUtf8 :: Display -> XftFont -> CString -> CInt -> Ptr XGlyphInfo -> IO ()

xftTextExtents :: Display -> XftFont -> String -> IO XGlyphInfo
xftTextExtents d f string =
    withArrayLen (map fromIntegral (UTF8.encode string)) $
    \len str_ptr -> alloca $ 
    \cglyph -> do
      cXftTextExtentsUtf8 d f str_ptr (fromIntegral len) cglyph
      peek cglyph
{-
Misunderstood the interface definition:
xftTextExtents :: Display -> XftFont -> String -> IO [XGlyphInfo]
xftTextExtents d f string =
    withArrayLen (map fromIntegral (UTF8.encode string)) $
    \len str_ptr -> allocaArray len $ 
    \cglyphs -> do
      cXftTextExtentsUtf8 d f str_ptr (fromIntegral len) cglyphs
      peekArray len cglyphs

-}
-- xftfont.c

-- We can't support this one:
-- XftFont *
-- XftFontOpen (Display *dpy, int screen, ...) _X_SENTINEL(0);

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

xftFontOpen dpy screen fontname =
  withCAString fontname $ \cfontname -> cXftFontOpen dpy (fromIntegral (screenNumberOfScreen screen)) cfontname

-- XftFont *
-- XftFontOpenXlfd (Display *dpy, int screen, _Xconst char *xlfd);

{- 
/* xftfreetype.c */

FT_Face
XftLockFace (XftFont *pub);

void
XftUnlockFace (XftFont *pub);

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

XftFont *
XftFontCopy (Display *dpy, XftFont *pub);

FcBool
XftInitFtLibrary(void);
-}

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