module Graphics.X11.Xft
(
XftMgr (mgrDisplay, mgrScreen)
, newXftMgr
, freeXftMgr
, Color
, pixel
, newColorName
, newColorValue
, freeColor
, openColorName
, openColorValue
, Draw
, display
, colormap
, visual
, drawable
, changeDraw
, newDraw
, newDrawBitmap
, newDrawAlpha
, freeDraw
, openDraw
, openDrawBitmap
, openDrawAlpha
, Font
, ascent
, descent
, height
, maxAdvanceWidth
, newFontName
, newFontXlfd
, freeFont
, openFontName
, openFontXlfd
, lockFace
, unlockFace
, textExtents
, textWidth
, textHeight
, drawString
, drawGlyphs
, drawRect
, RenderColor(..)
, GlyphInfo(..)
)
where
import qualified Graphics.X11 as X11
import Codec.Binary.UTF8.String as UTF8
import Control.Exception
import Control.Monad
import Data.IORef
import qualified Data.Map as M
import Foreign.C.Types
import Foreign.C.String
import Foreign.Ptr
import Foreign.Marshal.Alloc
import Foreign.Marshal.Array
import Foreign.Marshal.Utils
import Foreign.Storable
import Data.Int
import Data.Word
import System.IO
import System.IO.Unsafe
import System.Mem.Weak
type ObjectStore k = IORef (M.Map k (IO ()))
insertObj :: Ord k => ObjectStore k -> k -> IO () -> IO ()
insertObj ref k v = atomicModifyIORef ref $ \s -> (M.insert k v s, ())
deleteObj :: Ord k => ObjectStore k -> k -> IO ()
deleteObj ref k = atomicModifyIORef ref $ \s -> (k `M.delete` s, ())
data XftMgr = XftMgr
{ mgrDisplay :: X11.Display
, mgrScreen :: X11.Screen
, xftLock :: IO ()
, xftUnlock :: IO ()
, xftObjs :: ObjectStore IntPtr
}
newXftMgr :: X11.Display -> X11.Screen
-> IO ()
-> IO ()
-> IO XftMgr
newXftMgr dpy scr lock unlock = do
os <- newIORef M.empty
return XftMgr { mgrDisplay = dpy
, mgrScreen = scr
, xftLock = lock
, xftUnlock = unlock
, xftObjs = os
}
freeXftMgr :: XftMgr -> IO ()
freeXftMgr mgr = withoutLock $ finalizeObjs xftObjs
where getobjs s = (M.empty, M.elems s)
withoutLock = bracket_ (xftUnlock mgr) (xftLock mgr)
finalizeObjs f = sequence_ =<< atomicModifyIORef (f mgr) getobjs
openAny :: Ord k =>
XftMgr -> (XftMgr -> ObjectStore k)
-> (a -> IO ()) -> k -> a -> IO a
openAny mgr field close key obj = do
let finalizer = bracket_ (xftLock mgr) (xftUnlock mgr) $ do
deleteObj (field mgr) key
close obj
obj' <- mkWeak obj (obj, finalizer) (Just finalizer)
insertObj (field mgr) key (finalize obj')
return obj
openAnyWith :: Ord k => XftMgr -> (XftMgr -> ObjectStore k)
-> (c -> IO (Maybe a)) -> (a -> IO ()) -> (a -> IO k) -> c
-> IO (Maybe a)
openAnyWith mgr field open close keyf v = do
obj <- open v
case obj of Nothing -> return Nothing
Just obj' -> do key <- keyf obj'
key `seq` Just `fmap` openAny mgr field close key obj'
newtype Color = Color (Ptr Color)
foreign import ccall "XftColorAllocName"
xftColorAllocName :: X11.Display -> X11.Visual -> X11.Colormap
-> CString -> Color -> IO (Int32)
foreign import ccall "XftColorAllocValue"
xftColorAllocValue :: X11.Display -> X11.Visual -> X11.Colormap
-> (Ptr RenderColor) -> Color -> IO (Int32)
foreign import ccall "XftColorFree"
xftColorFree :: X11.Display -> X11.Visual -> X11.Colormap -> Color -> IO ()
pixel :: Color -> X11.Pixel
pixel (Color ptr) = fi $ unsafePerformIO $
peekCULong ptr (0)
newColorName :: X11.Display -> X11.Visual -> X11.Colormap -> String
-> IO (Maybe Color)
newColorName dpy v cm name = do
ptr <- mallocBytes ((12))
withCAString name $ \name' -> do
b <- xftColorAllocName dpy v cm name' $ Color ptr
if b /= 0 then return $ Just $ Color ptr
else free ptr >> return Nothing
newColorValue :: X11.Display -> X11.Visual -> X11.Colormap -> RenderColor
-> IO (Maybe Color)
newColorValue dpy v cm rc = do
ptr <- mallocBytes ((12))
with rc $ \rc' -> do
b <- xftColorAllocValue dpy v cm rc' $ Color ptr
if b /= 0 then return $ Just $ Color ptr
else free ptr >> return Nothing
freeColor :: X11.Display -> X11.Visual -> X11.Colormap -> Color -> IO ()
freeColor dpy v cm col@(Color ptr) = do
xftColorFree dpy v cm col
free ptr
openColorName :: XftMgr -> X11.Visual -> X11.Colormap -> String
-> IO (Maybe Color)
openColorName mgr vis cm =
openAnyWith mgr xftObjs open close (\(Color ptr) -> return $ ptrToIntPtr ptr)
where open = newColorName (mgrDisplay mgr) vis cm
close = freeColor (mgrDisplay mgr) vis cm
openColorValue :: XftMgr -> X11.Visual -> X11.Colormap -> RenderColor
-> IO (Maybe Color)
openColorValue mgr vis cm =
openAnyWith mgr xftObjs open close (\(Color ptr) -> return $ ptrToIntPtr ptr)
where open = newColorValue (mgrDisplay mgr) vis cm
close = freeColor (mgrDisplay mgr) vis cm
newtype Draw = Draw (Ptr Draw)
foreign import ccall "XftDrawCreate"
xftDrawCreate :: X11.Display -> X11.Drawable -> X11.Visual -> X11.Colormap -> IO Draw
foreign import ccall "XftDrawCreateBitmap"
xftDrawCreateBitmap :: X11.Display -> X11.Pixmap -> IO Draw
foreign import ccall "XftDrawCreateAlpha"
xftDrawCreateAlpha :: X11.Display -> X11.Pixmap -> CInt -> IO Draw
foreign import ccall "XftDrawChange"
xftDrawChange :: Draw -> X11.Drawable -> IO ()
foreign import ccall "XftDrawDisplay"
xftDrawDisplay :: Draw -> IO X11.Display
foreign import ccall "XftDrawDrawable"
xftDrawDrawable :: Draw -> IO X11.Drawable
foreign import ccall "XftDrawColormap"
xftDrawColormap :: Draw -> IO X11.Colormap
foreign import ccall "XftDrawVisual"
xftDrawVisual :: Draw -> IO X11.Visual
foreign import ccall "XftDrawDestroy"
xftDrawDestroy :: Draw -> IO ()
display :: Draw -> X11.Display
display = unsafePerformIO . xftDrawDisplay
colormap :: Draw -> X11.Colormap
colormap = unsafePerformIO . xftDrawColormap
visual :: Draw -> X11.Visual
visual = unsafePerformIO . xftDrawVisual
drawable :: Draw -> X11.Drawable
drawable = unsafePerformIO . xftDrawDrawable
newDraw :: X11.Display -> X11.Drawable -> X11.Visual -> X11.Colormap
-> IO (Maybe Draw)
newDraw dpy drw vis cm = do
Draw ptr <- xftDrawCreate dpy drw vis cm
if ptr == nullPtr then return Nothing
else return $ Just $ Draw ptr
newDrawBitmap :: X11.Display -> X11.Pixmap -> IO (Maybe Draw)
newDrawBitmap dpy pm = do
Draw ptr <- xftDrawCreateBitmap dpy pm
if ptr == nullPtr then return Nothing
else return $ Just $ Draw ptr
newDrawAlpha :: Integral a => X11.Display -> X11.Pixmap -> a -> IO (Maybe Draw)
newDrawAlpha dpy pm k = do
Draw ptr <- xftDrawCreateAlpha dpy pm $ fi k
if ptr == nullPtr then return Nothing
else return $ Just $ Draw ptr
freeDraw :: Draw -> IO ()
freeDraw = xftDrawDestroy
changeDraw :: Draw -> X11.Drawable -> IO ()
changeDraw = xftDrawChange
openDraw :: XftMgr -> X11.Drawable -> X11.Visual -> X11.Colormap
-> IO (Maybe Draw)
openDraw mgr drw vis =
openAnyWith mgr xftObjs open close (\(Draw ptr) -> return $ ptrToIntPtr ptr)
where open = newDraw (mgrDisplay mgr) drw vis
close = freeDraw
openDrawBitmap :: XftMgr -> X11.Drawable -> IO (Maybe Draw)
openDrawBitmap mgr =
openAnyWith mgr xftObjs open close (\(Draw ptr) -> return $ ptrToIntPtr ptr)
where open = newDrawBitmap (mgrDisplay mgr)
close = freeDraw
openDrawAlpha :: Integral a => XftMgr -> X11.Drawable -> a -> IO (Maybe Draw)
openDrawAlpha mgr drw =
openAnyWith mgr xftObjs open close (\(Draw ptr) -> return $ ptrToIntPtr ptr)
where open = newDrawAlpha (mgrDisplay mgr) drw
close = freeDraw
newtype Font = Font (Ptr Font)
foreign import ccall "XftFontOpenName"
xftFontOpenName :: X11.Display -> CInt -> CString -> IO Font
foreign import ccall "XftFontOpenXlfd"
xftFontOpenXlfd :: X11.Display -> CInt -> CString -> IO Font
foreign import ccall "XftLockFace"
xftLockFace :: Font -> IO ()
foreign import ccall "XftUnlockFace"
xftUnlockFace :: Font -> IO ()
foreign import ccall "XftFontClose"
xftFontClose :: X11.Display -> Font -> IO ()
ascent :: Integral a => Font -> a
ascent (Font p) = fi $ unsafePerformIO $ peekCUShort p (0)
descent :: Integral a => Font -> a
descent (Font p) = fi $ unsafePerformIO $ peekCUShort p (4)
height :: Integral a => Font -> a
height (Font p) = fi $ unsafePerformIO $ peekCUShort p (8)
maxAdvanceWidth :: Integral a => Font -> a
maxAdvanceWidth (Font p) = fi $ unsafePerformIO $ peekCUShort p (8)
newFontName :: X11.Display -> X11.Screen -> String -> IO (Maybe Font)
newFontName dpy screen fontname =
withCAString fontname $ \fontname' -> do
Font ptr <- xftFontOpenName dpy
(fi (X11.screenNumberOfScreen screen)) fontname'
if ptr == nullPtr then return Nothing else return $ Just $ Font ptr
newFontXlfd :: X11.Display -> X11.Screen -> String -> IO (Maybe Font)
newFontXlfd dpy screen xlfd =
withCAString xlfd $ \xlfd' -> do
Font ptr <- xftFontOpenXlfd dpy
(fi (X11.screenNumberOfScreen screen)) xlfd'
if ptr == nullPtr then return Nothing else return $ Just $ Font ptr
freeFont :: X11.Display -> Font -> IO ()
freeFont = xftFontClose
openFontName :: XftMgr -> String -> IO (Maybe Font)
openFontName mgr =
openAnyWith mgr xftObjs open close (\(Font ptr) -> return $ ptrToIntPtr ptr)
where open = newFontName (mgrDisplay mgr) (mgrScreen mgr)
close = freeFont (mgrDisplay mgr)
openFontXlfd :: XftMgr -> String -> IO (Maybe Font)
openFontXlfd mgr =
openAnyWith mgr xftObjs open close (\(Font ptr) -> return $ ptrToIntPtr ptr)
where open = newFontXlfd (mgrDisplay mgr) (mgrScreen mgr)
close = freeFont (mgrDisplay mgr)
lockFace :: Font -> IO ()
lockFace font = xftLockFace font >> return ()
unlockFace :: Font -> IO ()
unlockFace = xftUnlockFace
foreign import ccall "XftTextExtentsUtf8"
xftTextExtentsUtf8 :: X11.Display -> Font -> CString -> CInt -> Ptr GlyphInfo -> IO ()
textExtents :: X11.Display -> Font -> String -> IO GlyphInfo
textExtents dpy font s =
withArrayLen (map fi (UTF8.encode s)) $ \n s' ->
alloca $ \cglyph -> do
xftTextExtentsUtf8 dpy font s' (fi n) cglyph
peek cglyph
textWidth :: Integral a => X11.Display -> Font -> String -> IO a
textWidth dpy f = liftM (fi . glyphWidth) . textExtents dpy f
textHeight :: Integral a => X11.Display -> Font -> String -> IO a
textHeight dpy f = liftM (fi . glyphHeight) . textExtents dpy f
foreign import ccall "XftDrawGlyphs"
xftDrawGlyphs :: Draw -> Color -> Font -> CInt -> CInt -> Ptr (Word32) -> CInt -> IO ()
drawGlyphs :: (Integral x, Integral y, Integral c) => Draw -> Color -> Font ->
x -> y -> [c] -> IO ()
drawGlyphs drw col font x y s =
withArrayLen (map fi s) $ \len s' ->
xftDrawGlyphs drw col font (fi x) (fi y) s' (fi len)
foreign import ccall "XftDrawStringUtf8"
xftDrawStringUtf8 :: Draw -> Color -> Font -> CInt -> CInt -> Ptr (Word8) -> CInt -> IO ()
drawString :: (Integral x, Integral y) => Draw -> Color -> Font ->
x -> y -> String -> IO ()
drawString drw col font x y s =
withArrayLen (map fi (UTF8.encode s)) $ \len s' ->
xftDrawStringUtf8 drw col font (fi x) (fi y) s' (fi len)
foreign import ccall "XftDrawRect"
xftDrawRect :: Draw -> Color -> CInt -> CInt -> CUInt -> CUInt -> IO ()
drawRect :: (Integral x, Integral y, Integral w, Integral h) =>
Draw -> Color -> x -> y -> w -> h -> IO ()
drawRect d c x y w h = xftDrawRect d c (fi x) (fi y) (fi w) (fi h)
fi :: (Integral a, Num b) => a -> b
fi = fromIntegral
peekCULong :: Ptr a -> CInt -> IO Int
peekCULong ptr off = do
v <- peekByteOff ptr (fromIntegral off)
return (fromIntegral (v::CULong))
peekCUShort :: Ptr a -> CInt -> IO Int
peekCUShort ptr off = do
v <- peekByteOff ptr (fromIntegral off)
return (fromIntegral (v::CUShort))
pokeCUShort :: Ptr a -> CInt -> Int -> IO ()
pokeCUShort ptr off v =
pokeByteOff ptr (fromIntegral off) (fromIntegral v::CUShort)
peekCShort :: Ptr a -> CInt -> IO Int
peekCShort ptr off = do
v <- peekByteOff ptr (fromIntegral off)
return (fromIntegral (v::CShort))
pokeCShort :: Ptr a -> CInt -> Int -> IO ()
pokeCShort ptr off v =
pokeByteOff ptr (fromIntegral off) (fromIntegral v::CShort)
data RenderColor = RenderColor {
red :: Int
, green :: Int
, blue :: Int
, alpha :: Int
}
instance Storable RenderColor where
sizeOf _ = (8)
alignment _ = alignment (undefined::CInt)
peek p = do
r <- peekCUShort p (0)
g <- peekCUShort p (2)
b <- peekCUShort p (4)
a <- peekCUShort p (6)
return (RenderColor r g b a)
poke p (RenderColor r g b a) = do
pokeCUShort p (0) r
pokeCUShort p (2) g
pokeCUShort p (4) b
pokeCUShort p (6) a
data GlyphInfo = GlyphInfo {
glyphImageWidth :: Int
, glyphImageHeight :: Int
, glyphImageX :: Int
, glyphImageY :: Int
, glyphWidth :: Int
, glyphHeight :: Int
}
instance Storable GlyphInfo where
sizeOf _ = (12)
alignment _ = alignment (undefined::CInt)
peek p = do
w <- peekCUShort p (0)
h <- peekCUShort p (2)
x <- peekCShort p (4)
y <- peekCShort p (6)
xOff <- peekCShort p (8)
yOff <- peekCShort p (10)
return (GlyphInfo w h x y xOff yOff)
poke p (GlyphInfo w h x y xOff yOff) = do
pokeCUShort p (0) w
pokeCUShort p (2) h
pokeCShort p (4) x
pokeCShort p (6) y
pokeCShort p (8) xOff
pokeCShort p (10) yOff