summaryrefslogtreecommitdiffhomepage
path: root/src/MinXft.hsc
diff options
context:
space:
mode:
Diffstat (limited to 'src/MinXft.hsc')
-rw-r--r--src/MinXft.hsc333
1 files changed, 0 insertions, 333 deletions
diff --git a/src/MinXft.hsc b/src/MinXft.hsc
deleted file mode 100644
index b64a8b8..0000000
--- a/src/MinXft.hsc
+++ /dev/null
@@ -1,333 +0,0 @@
-------------------------------------------------------------------------------
--- |
--- Module: MinXft
--- Copyright: (c) 2012, 2014, 2015, 2017 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] -> String ->
- 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 =
- 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
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-05 07:00:53 +0000