# 1 "XMonad/Util/Font.cpphs"
# 1 "<built-in>"
# 1 "<command-line>"
# 14 "<command-line>"
# 1 "./dist/build/autogen/cabal_macros.h" 1
# 14 "<command-line>" 2
# 1 "XMonad/Util/Font.cpphs"
module XMonad.Util.Font (
XMonadFont(..)
, initXMF
, releaseXMF
, initCoreFont
, releaseCoreFont
, Align (..)
, stringPosition
, textWidthXMF
, textExtentsXMF
, printStringXMF
, stringToPixel
) where
import XMonad
import Foreign
import Data.List
import Graphics.X11.Xft
import Graphics.X11.Xrender
data XMonadFont = Core FontStruct
| Xft XftFont
stringToPixel :: MonadIO m => Display -> String -> m Pixel
stringToPixel d s = liftIO $ catch getIt fallBack
where getIt = initColor d s
fallBack = const $ return $ blackPixel d (defaultScreen d)
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
initXMF :: String -> X XMonadFont
initXMF s =
if xftPrefix `isPrefixOf` s then
do
dpy <- asks display
xftdraw <- io $ xftFontOpen dpy (defaultScreenOfDisplay dpy) (drop (length xftPrefix) s)
return (Xft xftdraw)
else
(initCoreFont s >>= (return . Core))
where xftPrefix = "xft:"
releaseXMF :: XMonadFont -> X ()
releaseXMF (Core fs) = releaseCoreFont fs
releaseXMF (Xft xftfont) = do
dpy <- asks display
io $ xftFontClose dpy xftfont
textWidthXMF :: MonadIO m => Display -> XMonadFont -> String -> m Int
textWidthXMF _ (Core fs) s = return $ fi $ textWidth fs s
textWidthXMF dpy (Xft xftdraw) s = liftIO $ do
gi <- xftTextExtents dpy xftdraw s
return $ xglyphinfo_width gi
textExtentsXMF :: MonadIO m => Display -> XMonadFont -> String -> m (FontDirection,Int32,Int32,CharStruct)
textExtentsXMF _ (Core fs) s = return $ textExtents fs s
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")
data Align = AlignCenter | AlignRight | AlignLeft
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 dpy 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
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
fi :: (Integral a, Num b) => a -> b
fi = fromIntegral