{-# LANGUAGE CPP #-}
module Xmobar.X11.Text
( XFont(..)
, initFont
, initCoreFont
, initUtf8Font
, textExtents
, textWidth
) where
import Control.Exception (SomeException, handle)
import Data.List
import Foreign
import Graphics.X11.Xlib hiding (textExtents, textWidth)
import qualified Graphics.X11.Xlib as Xlib (textExtents, textWidth)
import Graphics.X11.Xlib.Extras
import System.Mem.Weak ( addFinalizer )
#if defined XFT
import Xmobar.X11.MinXft
import Graphics.X11.Xrender
#else
import System.IO(hPutStrLn, stderr)
#endif
data XFont = Core FontStruct
| Utf8 FontSet
#ifdef XFT
| Xft [AXftFont]
#endif
initFont :: Display -> String -> IO XFont
initFont :: Display -> String -> IO XFont
initFont Display
d String
s =
let xftPrefix :: String
xftPrefix = String
"xft:" in
if String
xftPrefix String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
s then
#ifdef XFT
fmap Xft $ initXftFont d s
#else
do
Handle -> String -> IO ()
hPutStrLn Handle
stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Warning: Xmobar must be built with "
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"the with_xft flag to support font '" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
".' Falling back on default."
Display -> String -> IO XFont
initFont Display
d String
miscFixedFont
#endif
else
(FontSet -> XFont) -> IO FontSet -> IO XFont
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FontSet -> XFont
Utf8 (IO FontSet -> IO XFont) -> IO FontSet -> IO XFont
forall a b. (a -> b) -> a -> b
$ Display -> String -> IO FontSet
initUtf8Font Display
d String
s
miscFixedFont :: String
miscFixedFont :: String
miscFixedFont = String
"-misc-fixed-*-*-*-*-*-*-*-*-*-*-*-*"
initCoreFont :: Display -> String -> IO FontStruct
initCoreFont :: Display -> String -> IO FontStruct
initCoreFont Display
d String
s = do
FontStruct
f <- (SomeException -> IO FontStruct) -> IO FontStruct -> IO FontStruct
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle SomeException -> IO FontStruct
fallBack IO FontStruct
getIt
FontStruct -> IO () -> IO ()
forall key. key -> IO () -> IO ()
addFinalizer FontStruct
f (Display -> FontStruct -> IO ()
freeFont Display
d FontStruct
f)
FontStruct -> IO FontStruct
forall (m :: * -> *) a. Monad m => a -> m a
return FontStruct
f
where getIt :: IO FontStruct
getIt = Display -> String -> IO FontStruct
loadQueryFont Display
d String
s
fallBack :: SomeException -> IO FontStruct
fallBack :: SomeException -> IO FontStruct
fallBack = IO FontStruct -> SomeException -> IO FontStruct
forall a b. a -> b -> a
const (IO FontStruct -> SomeException -> IO FontStruct)
-> IO FontStruct -> SomeException -> IO FontStruct
forall a b. (a -> b) -> a -> b
$ Display -> String -> IO FontStruct
loadQueryFont Display
d String
miscFixedFont
initUtf8Font :: Display -> String -> IO FontSet
initUtf8Font :: Display -> String -> IO FontSet
initUtf8Font Display
d String
s = do
([String]
_,String
_,FontSet
f) <- (SomeException -> IO ([String], String, FontSet))
-> IO ([String], String, FontSet) -> IO ([String], String, FontSet)
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle SomeException -> IO ([String], String, FontSet)
fallBack IO ([String], String, FontSet)
getIt
FontSet -> IO () -> IO ()
forall key. key -> IO () -> IO ()
addFinalizer FontSet
f (Display -> FontSet -> IO ()
freeFontSet Display
d FontSet
f)
FontSet -> IO FontSet
forall (m :: * -> *) a. Monad m => a -> m a
return FontSet
f
where getIt :: IO ([String], String, FontSet)
getIt = Display -> String -> IO ([String], String, FontSet)
createFontSet Display
d String
s
fallBack :: SomeException -> IO ([String], String, FontSet)
fallBack :: SomeException -> IO ([String], String, FontSet)
fallBack = IO ([String], String, FontSet)
-> SomeException -> IO ([String], String, FontSet)
forall a b. a -> b -> a
const (IO ([String], String, FontSet)
-> SomeException -> IO ([String], String, FontSet))
-> IO ([String], String, FontSet)
-> SomeException
-> IO ([String], String, FontSet)
forall a b. (a -> b) -> a -> b
$ Display -> String -> IO ([String], String, FontSet)
createFontSet Display
d String
miscFixedFont
#ifdef XFT
initXftFont :: Display -> String -> IO [AXftFont]
initXftFont d s = do
let fontNames = wordsBy (== ',') (drop 4 s)
mapM openFont fontNames
where
openFont fontName = do
f <- openAXftFont d (defaultScreenOfDisplay d) fontName
addFinalizer f (closeAXftFont d f)
return f
wordsBy p str = case dropWhile p str of
"" -> []
str' -> w : wordsBy p str''
where
(w, str'') = break p str'
#endif
textWidth :: Display -> XFont -> String -> IO Int
textWidth :: Display -> XFont -> String -> IO Int
textWidth Display
_ (Utf8 FontSet
fs) String
s = Int -> IO Int
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> IO Int) -> Int -> IO Int
forall a b. (a -> b) -> a -> b
$ Int32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int32 -> Int) -> Int32 -> Int
forall a b. (a -> b) -> a -> b
$ FontSet -> String -> Int32
wcTextEscapement FontSet
fs String
s
textWidth Display
_ (Core FontStruct
fs) String
s = Int -> IO Int
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> IO Int) -> Int -> IO Int
forall a b. (a -> b) -> a -> b
$ Int32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int32 -> Int) -> Int32 -> Int
forall a b. (a -> b) -> a -> b
$ FontStruct -> String -> Int32
Xlib.textWidth FontStruct
fs String
s
#ifdef XFT
textWidth dpy (Xft xftdraw) s = do
gi <- xftTxtExtents' dpy xftdraw s
return $ xglyphinfo_xOff gi
#endif
textExtents :: XFont -> String -> IO (Int32,Int32)
textExtents :: XFont -> String -> IO (Int32, Int32)
textExtents (Core FontStruct
fs) String
s = do
let (FontDirection
_,Int32
a,Int32
d,CharStruct
_) = FontStruct -> String -> (FontDirection, Int32, Int32, CharStruct)
Xlib.textExtents FontStruct
fs String
s
(Int32, Int32) -> IO (Int32, Int32)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int32
a,Int32
d)
textExtents (Utf8 FontSet
fs) String
s = do
let (Rectangle
_,Rectangle
rl) = FontSet -> String -> (Rectangle, Rectangle)
wcTextExtents FontSet
fs String
s
ascent :: Int32
ascent = Int32 -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int32 -> Int32) -> Int32 -> Int32
forall a b. (a -> b) -> a -> b
$ Int32 -> Int32
forall a. Num a => a -> a
negate (Rectangle -> Int32
rect_y Rectangle
rl)
descent :: Int32
descent = Dimension -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Dimension -> Int32) -> Dimension -> Int32
forall a b. (a -> b) -> a -> b
$ Rectangle -> Dimension
rect_height Rectangle
rl Dimension -> Dimension -> Dimension
forall a. Num a => a -> a -> a
+ Int32 -> Dimension
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Rectangle -> Int32
rect_y Rectangle
rl)
(Int32, Int32) -> IO (Int32, Int32)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int32
ascent, Int32
descent)
#ifdef XFT
textExtents (Xft xftfonts) _ = do
ascent <- fromIntegral `fmap` xft_ascent' xftfonts
descent <- fromIntegral `fmap` xft_descent' xftfonts
return (ascent, descent)
#endif