From 1085043f0ceb4a3f76e7fed3f9ddd0f2b59cb6c5 Mon Sep 17 00:00:00 2001 From: Andrea Rossato Date: Sun, 2 Mar 2008 10:57:12 +0100 Subject: Font and XUtils: add UTF-8 support and various fixes related to XFT - printStringXMF: use the background color for XFT fonts too - textWidthXMF now returns the text width even with xft fonts - textExtentsXMF will now return only the ascend and the descent of a string. - stringPosition now takes the display too - add support for UTF-8 locales: if the contrib library is compiled with the 'with_xft' or the 'with_utf8' option the prompt and the decoration system will support UTF-8 locales - this requires utf8-strings. darcs-hash:20080302095712-32816-f3d6d06ff9d921288b1625e4bfd643013d2075ec.gz --- XMonad/Util/Font.hsc | 226 +++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 226 insertions(+) create mode 100644 XMonad/Util/Font.hsc (limited to 'XMonad/Util/Font.hsc') diff --git a/XMonad/Util/Font.hsc b/XMonad/Util/Font.hsc new file mode 100644 index 0000000..5be594d --- /dev/null +++ b/XMonad/Util/Font.hsc @@ -0,0 +1,226 @@ +---------------------------------------------------------------------------- +-- | +-- Module : XMonad.Util.Font +-- Copyright : (c) 2007 Andrea Rossato and Spencer Janssen +-- License : BSD-style (see xmonad/LICENSE) +-- +-- Maintainer : andrea.rossato@unibz.it +-- Stability : unstable +-- Portability : unportable +-- +-- A module for abstracting a font facility over Core fonts and Xft +-- +----------------------------------------------------------------------------- + +module XMonad.Util.Font + ( -- * Usage: + -- $usage + XMonadFont(..) + , initXMF + , releaseXMF + , initCoreFont + , releaseCoreFont + , initUtf8Font + , releaseUtf8Font + , Align (..) + , stringPosition + , textWidthXMF + , textExtentsXMF + , printStringXMF + , stringToPixel + , decodeInput + , encodeOutput + ) where + +import XMonad +import Foreign +import Control.Applicative +import Data.Maybe + +#ifdef XFT +import Data.List +import Graphics.X11.Xft +import Graphics.X11.Xrender +#endif + +#if defined XFT || defined UTF8 +import Codec.Binary.UTF8.String (encodeString, decodeString) +import Foreign.C +#endif + +-- Hide the Core Font/Xft switching here +data XMonadFont = Core FontStruct + | Utf8 FontSet +#ifdef XFT + | Xft XftFont +#endif + +-- $usage +-- See "Xmonad.Layout.Tabbed" or "XMonad.Prompt" for usage examples + +-- | Get the Pixel value for a named color: if an invalid name is +-- given the black pixel will be returned. +stringToPixel :: (Functor m, MonadIO m) => Display -> String -> m Pixel +stringToPixel d s = fromMaybe fallBack <$> io getIt + where getIt = initColor d s + fallBack = blackPixel d (defaultScreen d) + + +-- | Given a fontname returns the font structure. If the font name is +-- not valid the default font will be loaded and returned. +initCoreFont :: String -> X FontStruct +initCoreFont s = do + d <- asks display + io $ catch (getIt d) (fallBack d) + where getIt d = loadQueryFont d s + fallBack d = const $ loadQueryFont d "-misc-fixed-*-*-*-*-10-*-*-*-*-*-*-*" + +releaseCoreFont :: FontStruct -> X () +releaseCoreFont fs = do + d <- asks display + io $ freeFont d fs + +initUtf8Font :: String -> X FontSet +initUtf8Font s = do + d <- asks display + (_,_,fs) <- io $ catch (getIt d) (fallBack d) + return fs + where getIt d = createFontSet d s + fallBack d = const $ createFontSet d "-misc-fixed-*-*-*-*-10-*-*-*-*-*-*-*" + +releaseUtf8Font :: FontSet -> X () +releaseUtf8Font fs = do + d <- asks display + io $ freeFontSet d fs + +-- | When initXMF gets a font name that starts with 'xft:' it switchs to the Xft backend +-- Example: 'xft: Sans-10' +initXMF :: String -> X XMonadFont +initXMF s = +#ifdef XFT + if xftPrefix `isPrefixOf` s then + do io setupLocale + dpy <- asks display + xftdraw <- io $ xftFontOpen dpy (defaultScreenOfDisplay dpy) (drop (length xftPrefix) s) + return (Xft xftdraw) + else +#endif +#ifdef UTF8 + (io setupLocale >> initUtf8Font s >>= (return . Utf8)) +#else + (initCoreFont s >>= (return . Core)) +#endif +#ifdef XFT + where xftPrefix = "xft:" +#endif + +releaseXMF :: XMonadFont -> X () +#ifdef XFT +releaseXMF (Xft xftfont) = do + dpy <- asks display + io $ xftFontClose dpy xftfont +#endif +releaseXMF (Utf8 fs) = releaseUtf8Font fs +releaseXMF (Core fs) = releaseCoreFont fs + + +textWidthXMF :: MonadIO m => Display -> XMonadFont -> String -> m Int +textWidthXMF _ (Utf8 fs) s = return $ fi $ wcTextEscapement fs s +textWidthXMF _ (Core fs) s = return $ fi $ textWidth fs s +#ifdef XFT +textWidthXMF dpy (Xft xftdraw) s = liftIO $ do + gi <- xftTextExtents dpy xftdraw s + return $ xglyphinfo_xOff gi +#endif + +textExtentsXMF :: MonadIO m => XMonadFont -> String -> m (Int32,Int32) +textExtentsXMF (Utf8 fs) s = do + let (_,rl) = wcTextExtents fs s + ascent = fi $ - (rect_y rl) + descent = fi $ rect_height rl + (fi $ rect_y rl) + return (ascent, descent) +textExtentsXMF (Core fs) s = do + let (_,a,d,_) = textExtents fs s + return (a,d) +#ifdef XFT +textExtentsXMF (Xft xftfont) _ = io $ do + ascent <- fi `fmap` xftfont_ascent xftfont + descent <- fi `fmap` xftfont_descent xftfont + return (ascent, descent) +#endif + +-- | String position +data Align = AlignCenter | AlignRight | AlignLeft + +-- | Return the string x and y 'Position' in a 'Rectangle', given a +-- 'FontStruct' and the 'Align'ment +stringPosition :: (Functor m, MonadIO m) => Display -> XMonadFont -> Rectangle -> Align -> String -> m (Position,Position) +stringPosition dpy fs (Rectangle _ _ w h) al s = do + width <- textWidthXMF dpy fs s + (a,d) <- textExtentsXMF fs s + let y = fi $ ((h - fi (a + d)) `div` 2) + fi a; + x = case al of + AlignCenter -> fi (w `div` 2) - fi (width `div` 2) + AlignLeft -> 1 + AlignRight -> fi (w - (fi width + 1)); + return (x,y) + +printStringXMF :: (Functor m, MonadIO m) => Display -> Drawable -> XMonadFont -> GC -> String -> String + -> Position -> Position -> String -> m () +printStringXMF d p (Core fs) gc fc bc x y s = io $ do + setFont d gc $ fontFromFontStruct fs + [fc',bc'] <- mapM (stringToPixel d) [fc,bc] + setForeground d gc fc' + setBackground d gc bc' + drawImageString d p gc x y s +printStringXMF d p (Utf8 fs) gc fc bc x y s = io $ do + [fc',bc'] <- mapM (stringToPixel d) [fc,bc] + setForeground d gc fc' + setBackground d gc bc' + io $ wcDrawImageString d p fs gc x y s +#ifdef XFT +printStringXMF dpy drw fs@(Xft font) gc fc bc x y s = do + let screen = defaultScreenOfDisplay dpy + colormap = defaultColormapOfScreen screen + visual = defaultVisualOfScreen screen + bcolor <- stringToPixel dpy bc + (a,d) <- textExtentsXMF fs s + gi <- io $ xftTextExtents dpy font s + io $ setForeground dpy gc bcolor + io $ fillRectangle dpy drw gc (x - fi (xglyphinfo_x gi)) + (y - fi a) + (fi $ xglyphinfo_xOff gi) + (fi $ a + d) + io $ withXftDraw dpy drw visual colormap $ + \draw -> withXftColorName dpy visual colormap fc $ + \color -> xftDrawString draw color font x y s +#endif + +decodeInput :: String -> String +#if defined XFT || defined UTF8 +decodeInput = decodeString +#else +decodeInput = id +#endif + +encodeOutput :: String -> String +#if defined XFT || defined UTF8 +encodeOutput = encodeString +#else +encodeOutput = id +#endif + +-- | Short-hand for 'fromIntegral' +fi :: (Integral a, Num b) => a -> b +fi = fromIntegral + +#if defined XFT || defined UTF8 +#include +foreign import ccall unsafe "locale.h setlocale" + setlocale :: CInt -> CString -> IO CString + +setupLocale :: IO () +setupLocale = withCString "" $ \s -> do + setlocale (#const LC_ALL) s + return () +#endif -- cgit v1.2.3