path: root/src/MinXft.hsc

------------------------------------------------------------------------------
-- |
-- Module: MinXft
-- Copyright: (c) 2012, 2014, 2015 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 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)

#include <X11/Xft/Xft.h>

-- Color Handling

newtype AXftColor = AXftColor (Ptr AXftColor)

foreign import ccall "XftColorAllocName"
    cXftColorAllocName :: Display -> Visual -> Colormap -> CString -> AXftColor -> IO (#type Bool)

-- 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 d v cm n = do
  color <- mallocBytes (#size XftColor)
  withCAString n $ \str -> cXftColorAllocName d v cm str (AXftColor color)
  return (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 p) = peekCUShort p #{offset XftFont, ascent}

xft_ascent' :: [AXftFont] -> IO Int
xft_ascent' = (fmap maximum) . (mapM xft_ascent)

xft_descent :: AXftFont -> IO Int
xft_descent (AXftFont p) = peekCUShort p #{offset XftFont, descent}

xft_descent' :: [AXftFont] -> IO Int
xft_descent' = (fmap maximum) . (mapM xft_descent)

xft_height :: AXftFont -> IO Int
xft_height (AXftFont p) = peekCUShort p #{offset XftFont, height}

xft_height' :: [AXftFont] -> IO Int
xft_height' = (fmap maximum) . (mapM xft_height)

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

xftTxtExtents :: Display -> AXftFont -> String -> IO XGlyphInfo
xftTxtExtents d f string =
    withArrayLen (map fi (UTF8.encode string)) $
    \len str_ptr -> alloca $
    \cglyph -> do
      cXftTextExtentsUtf8 d f str_ptr (fi len) cglyph
      peek cglyph

xftTxtExtents' :: Display -> [AXftFont] -> String -> IO XGlyphInfo
xftTxtExtents' d fs string = do
    chunks <- getChunks d fs string
    let (_, _, gi, _, _) = last chunks
    return gi

foreign import ccall "XftFontOpenName"
  c_xftFontOpen :: Display -> CInt -> CString -> IO AXftFont

openAXftFont :: Display -> Screen -> String -> IO AXftFont
openAXftFont dpy screen name =
    withCAString name $
      \cname -> c_xftFontOpen dpy (fi (screenNumberOfScreen screen)) cname

foreign import ccall "XftFontClose"
  closeAXftFont :: Display -> AXftFont -> IO ()

foreign import ccall "XftCharExists"
  cXftCharExists :: Display -> AXftFont -> (#type FcChar32) -> IO (#type FcBool)

xftCharExists :: Display -> AXftFont -> Char -> IO Bool
xftCharExists d f c = bool `fmap` cXftCharExists d f (fi $ ord c)
  where
    bool 0 = False
    bool _ = True
-- Drawing

fi :: (Integral a, Num b) => a -> b
fi = 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 d p v c act = do
  draw <- c_xftDrawCreate d p v c
  a <- act draw
  c_xftDrawDestroy draw
  return a

foreign import ccall "XftDrawStringUtf8"
  cXftDrawStringUtf8 :: AXftDraw -> AXftColor -> AXftFont -> CInt -> CInt -> Ptr (#type FcChar8) -> CInt -> IO ()

drawXftString :: (Integral a1, Integral a) =>
                 AXftDraw -> AXftColor -> AXftFont -> a -> a1 -> String -> IO ()
drawXftString d c f x y string =
    withArrayLen (map fi (UTF8.encode string))
      (\len ptr -> cXftDrawStringUtf8 d c f (fi x) (fi y) ptr (fi len))

drawXftString' :: AXftDraw ->
                  AXftColor ->
                  [AXftFont] ->
                  Integer ->
                  Integer ->
                  String -> IO ()
drawXftString' d c fs x y string = do
    display <- c_xftDrawDisplay d
    chunks <- getChunks display fs string
    mapM_ (\(f, s, _, xo, yo) -> drawXftString d c f (x+xo) (y+yo) s) chunks

-- Split string and determine fonts/offsets for individual parts
getChunks :: Display -> [AXftFont] -> [Char] ->
             IO [(AXftFont, String, XGlyphInfo, Integer, Integer)]
getChunks disp fts str = do
    chunks <- getFonts disp fts str
    getOffsets (XGlyphInfo 0 0 0 0 0 0) chunks
  where
    -- Split string and determine fonts for individual parts
    getFonts _ [] _ = return []
    getFonts _ _ [] = return []
    getFonts _ [ft] s = return [(ft, s)]
    getFonts d fonts@(ft:_) s = do
        -- Determine which glyph can be rendered by current font
        glyphs <- mapM (xftCharExists d ft) s
        -- Split string into parts that can/cannot be rendered
        let splits = split (runs glyphs) s
        -- Determine which font to render each chunk with
        concat `fmap` mapM (getFont d fonts) splits

    -- Determine fonts for substrings
    getFont _ [] _ = return []
    getFont _ [ft] (_, s) = return [(ft, s)] -- Last font, use it
    getFont _ (ft:_) (True, s) = return [(ft, s)] -- Current font can render this substring
    getFont d (_:fs) (False, s) = getFonts d fs s -- Fallback to next font

    -- Helpers
    runs [] = []
    runs (x:xs) = let (h, t) = span (==x) xs in (x, length h + 1) : runs t
    split [] _ = []
    split ((x, c):xs) s = let (h, t) = splitAt c s in (x, h) : split xs t

    -- Determine coordinates for chunks using extents
    getOffsets _ [] = return []
    getOffsets (XGlyphInfo _ _ x y xo yo) ((f, s):chunks) = do
        (XGlyphInfo w' h' _ _ xo' yo') <- xftTxtExtents disp f s
        let gi = XGlyphInfo (xo+w') (yo+h') x y (xo+xo') (yo+yo')
        rest <- getOffsets gi chunks
        return $ (f, s, gi, fromIntegral xo, fromIntegral yo) : 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 draw color x y width height =
  cXftDrawRect draw color (fi x) (fi y) (fi width) (fi height)

#include <X11/extensions/Xrender.h>

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 _ = #{size XRenderPictureAttributes}
    alignment _ = alignment (undefined :: CInt)
    peek _ = return XRenderPictureAttributes
    poke p XRenderPictureAttributes = do
        memset p 0 #{size XRenderPictureAttributes}

-- | Convenience function, gives us an XRender handle to a traditional
-- Pixmap.  Don't let it escape.
withRenderPicture :: Display -> Drawable -> (Picture -> IO a) -> IO ()
withRenderPicture d p f = do
    format <- xRenderFindStandardFormat d 1 -- PictStandardRGB24
    alloca $ \attr -> do
        pic <- xRenderCreatePicture d p format 0 attr
        f pic
        xRenderFreePicture d 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 d c f = do
    pic <- with c (xRenderCreateSolidFill d)
    f pic
    xRenderFreePicture d pic

-- | Drawing the background to a pixmap and taking into account
-- transparency
drawBackground ::  Display -> Drawable -> String -> Int -> Rectangle -> IO ()
drawBackground d p bgc alpha (Rectangle x y wid ht) = do
  let render opt bg pic m =
        xRenderComposite d opt bg m pic
                        (fromIntegral x) (fromIntegral y) 0 0
                        0 0 (fromIntegral wid) (fromIntegral ht)
  withRenderPicture d p $ \pic -> do
    -- Handle background color
    bgcolor <- parseRenderColor d bgc
    withRenderFill d bgcolor $ \bgfill ->
      withRenderFill d
                     (XRenderColor 0 0 0 (257 * alpha))
                     (render pictOpSrc bgfill pic)
    -- Handle transparency
    internAtom d "_XROOTPMAP_ID" False >>= \xid ->
      let xroot = defaultRootWindow d in
      alloca $ \x1 ->
      alloca $ \x2 ->
      alloca $ \x3 ->
      alloca $ \x4 ->
      alloca $ \pprop -> do
        xGetWindowProperty d xroot xid 0 1 False 20 x1 x2 x3 x4 pprop
        prop <- peek pprop
        when (prop /= nullPtr) $ do
          rootbg <- peek (castPtr prop) :: IO Pixmap
          xFree prop
          withRenderPicture d rootbg $ \bgpic ->
            withRenderFill d (XRenderColor 0 0 0 (0xFFFF - 257 * alpha))
                           (render pictOpAdd bgpic pic)

-- | Parses color into XRender color (allocation not necessary!)
parseRenderColor :: Display -> String -> IO XRenderColor
parseRenderColor d c = do
    let colormap = defaultColormap d (defaultScreen d)
    Color _ red green blue _ <- parseColor d colormap c
    return $ XRenderColor (fromIntegral red) (fromIntegral green) (fromIntegral blue) 0xFFFF

pictOpSrc, pictOpAdd :: PictOp
pictOpSrc = 1
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