mirror of
https://github.com/xmonad/xmonad-contrib.git
synced 2025-08-01 04:31:52 -07:00
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.
This commit is contained in:
Andrea Rossato
@@ -91,8 +91,8 @@ flashName c (Rectangle _ _ wh ht) wrs = do
|
||||
d <- asks display
|
||||
n <- withWindowSet (return . S.tag . S.workspace . S.current)
|
||||
f <- initXMF (swn_font c)
|
||||
width <- textWidthXMF d f n
|
||||
(_,as,ds,_) <- textExtentsXMF f n
|
||||
width <- textWidthXMF d f n
|
||||
(as,ds) <- textExtentsXMF f n
|
||||
let hight = as + ds
|
||||
y = (fi ht - hight + 2) `div` 2
|
||||
x = (fi wh - width + 2) `div` 2
|
||||
|
||||
@@ -41,6 +41,8 @@ module XMonad.Prompt
|
||||
, splitInSubListsAt
|
||||
, breakAtSpace
|
||||
, uniqSort
|
||||
, decodeInput
|
||||
, encodeOutput
|
||||
) where
|
||||
|
||||
import XMonad hiding (config, io)
|
||||
@@ -336,7 +338,7 @@ keyPressHandle mask (ks,_)
|
||||
-- insert a character
|
||||
keyPressHandle _ (_,s)
|
||||
| s == "" = eventLoop handle
|
||||
| otherwise = do insertString s
|
||||
| otherwise = do insertString (decodeInput s)
|
||||
updateWindows
|
||||
eventLoop handle
|
||||
|
||||
@@ -504,7 +506,7 @@ printPrompt drw = do
|
||||
ht = height c
|
||||
fsl <- io $ textWidthXMF (dpy st) fs f
|
||||
psl <- io $ textWidthXMF (dpy st) fs p
|
||||
(_,asc,desc,_) <- io $ textExtentsXMF fs str
|
||||
(asc,desc) <- io $ textExtentsXMF fs str
|
||||
let y = fi $ ((ht - fi (asc + desc)) `div` 2) + fi asc
|
||||
x = (asc + desc) `div` 2
|
||||
|
||||
@@ -571,7 +573,7 @@ getComplWinDim compl = do
|
||||
(x,y) = case position c of
|
||||
Top -> (0,ht)
|
||||
Bottom -> (0, (0 + rem_height - actual_height))
|
||||
(_,asc,desc,_) <- io $ textExtentsXMF fs $ head compl
|
||||
(asc,desc) <- io $ textExtentsXMF fs $ head compl
|
||||
let yp = fi $ (ht + fi (asc - desc)) `div` 2
|
||||
xp = (asc + desc) `div` 2
|
||||
yy = map fi . take (fi actual_rows) $ [yp,(yp + ht)..]
|
||||
|
||||
@@ -1,156 +0,0 @@
|
||||
----------------------------------------------------------------------------
|
||||
-- |
|
||||
-- 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
|
||||
, Align (..)
|
||||
, stringPosition
|
||||
, textWidthXMF
|
||||
, textExtentsXMF
|
||||
, printStringXMF
|
||||
, stringToPixel
|
||||
) 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
|
||||
|
||||
-- Hide the Core Font/Xft switching here
|
||||
data XMonadFont = Core FontStruct
|
||||
#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 <$> liftIO 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
|
||||
|
||||
-- | 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
|
||||
dpy <- asks display
|
||||
xftdraw <- io $ xftFontOpen dpy (defaultScreenOfDisplay dpy) (drop (length xftPrefix) s)
|
||||
return (Xft xftdraw)
|
||||
else
|
||||
#endif
|
||||
(initCoreFont s >>= (return . Core))
|
||||
#ifdef XFT
|
||||
where xftPrefix = "xft:"
|
||||
#endif
|
||||
|
||||
releaseXMF :: XMonadFont -> X ()
|
||||
releaseXMF (Core fs) = releaseCoreFont fs
|
||||
#ifdef XFT
|
||||
releaseXMF (Xft xftfont) = do
|
||||
dpy <- asks display
|
||||
io $ xftFontClose dpy xftfont
|
||||
#endif
|
||||
|
||||
textWidthXMF :: MonadIO m => Display -> XMonadFont -> String -> m Int
|
||||
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_width gi
|
||||
#endif
|
||||
|
||||
textExtentsXMF :: MonadIO m => XMonadFont -> String -> m (FontDirection,Int32,Int32,CharStruct)
|
||||
textExtentsXMF (Core fs) s = return $ textExtents fs s
|
||||
#ifdef XFT
|
||||
textExtentsXMF (Xft xftfont) _ = liftIO $ do
|
||||
ascent <- xftfont_ascent xftfont
|
||||
descent <- xftfont_descent xftfont
|
||||
return (error "Font direction touched", fi ascent, fi descent, error "Font overall size touched")
|
||||
#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 :: XMonadFont -> Rectangle -> Align -> String -> X (Position,Position)
|
||||
stringPosition fs (Rectangle _ _ w h) al s = do
|
||||
dpy <- asks display
|
||||
width <- io $ textWidthXMF dpy fs s
|
||||
(_,a,d,_) <- io $ 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 :: MonadIO m => Display -> Drawable -> XMonadFont -> GC -> String -> String
|
||||
-> Position -> Position -> String -> m ()
|
||||
printStringXMF d p (Core fs) gc fc bc x y s = liftIO $ 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
|
||||
|
||||
#ifdef XFT
|
||||
printStringXMF dpy drw (Xft font) _ fc _ x y s = do
|
||||
let screen = defaultScreenOfDisplay dpy;
|
||||
colormap = defaultColormapOfScreen screen;
|
||||
visual = defaultVisualOfScreen screen;
|
||||
liftIO $ withXftDraw dpy drw visual colormap $
|
||||
\draw -> withXftColorName dpy visual colormap fc $
|
||||
\color -> xftDrawString draw color font x y s
|
||||
#endif
|
||||
|
||||
|
||||
-- | Short-hand for 'fromIntegral'
|
||||
fi :: (Integral a, Num b) => a -> b
|
||||
fi = fromIntegral
|
||||
226
XMonad/Util/Font.hsc
Normal file
226
XMonad/Util/Font.hsc
Normal file
@@ -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 <locale.h>
|
||||
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
|
||||
@@ -117,7 +117,8 @@ paintAndWrite :: Window -- ^ The window where to draw
|
||||
-> String -- ^ String to be printed
|
||||
-> X ()
|
||||
paintAndWrite w fs wh ht bw bc borc ffc fbc al str = do
|
||||
(x,y) <- stringPosition fs (Rectangle 0 0 wh ht) al str
|
||||
d <- asks display
|
||||
(x,y) <- stringPosition d fs (Rectangle 0 0 wh ht) al str
|
||||
paintWindow' w (Rectangle x y wh ht) bw bc borc ms
|
||||
where ms = Just (fs,ffc,fbc,str)
|
||||
|
||||
|
||||
@@ -34,6 +34,9 @@ flag small_base
|
||||
flag use_xft
|
||||
description: Use Xft to render text
|
||||
|
||||
flag with_utf8
|
||||
description: Enable Utf8 support
|
||||
|
||||
flag testing
|
||||
description: Testing mode
|
||||
default: False
|
||||
@@ -45,9 +48,15 @@ library
|
||||
build-depends: base < 3
|
||||
|
||||
if flag(use_xft)
|
||||
build-depends: X11-xft >= 0.2
|
||||
build-depends: X11-xft >= 0.2, utf8-string
|
||||
extensions: ForeignFunctionInterface
|
||||
cpp-options: -DXFT
|
||||
|
||||
if flag(with_utf8)
|
||||
build-depends: utf8-string
|
||||
extensions: ForeignFunctionInterface
|
||||
cpp-options: -DUTF8
|
||||
|
||||
build-depends: mtl, unix, X11>=1.4.1, xmonad==0.6
|
||||
ghc-options: -Wall
|
||||
|
||||
|
||||
Reference in New Issue
Block a user