module XMonad.Util.Font
(
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
data XMonadFont = Core FontStruct
| Utf8 FontSet
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)
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
initXMF :: String -> X XMonadFont
initXMF s =
(initCoreFont s >>= (return . Core))
releaseXMF :: XMonadFont -> X ()
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
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)
data Align = AlignCenter | AlignRight | AlignLeft
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
decodeInput :: String -> String
decodeInput = id
encodeOutput :: String -> String
encodeOutput = id
fi :: (Integral a, Num b) => a -> b
fi = fromIntegral