{-# LANGUAGE CPP #-}
----------------------------------------------------------------------------
-- |
-- Module      :  XMonad.Util.Font
-- Description :  A module for abstracting a font facility over Core fonts and Xft.
-- 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
    , pixelToString
    , fi
    ) where

import XMonad
import XMonad.Prelude
import Foreign
import Control.Exception as E
import Text.Printf (printf)

#ifdef XFT
import Graphics.X11.Xft
import Graphics.X11.Xrender
#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 :: Display -> String -> m Pixel
stringToPixel Display
d String
s = Pixel -> Maybe Pixel -> Pixel
forall a. a -> Maybe a -> a
fromMaybe Pixel
fallBack (Maybe Pixel -> Pixel) -> m (Maybe Pixel) -> m Pixel
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Maybe Pixel) -> m (Maybe Pixel)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io IO (Maybe Pixel)
getIt
    where getIt :: IO (Maybe Pixel)
getIt    = Display -> String -> IO (Maybe Pixel)
initColor Display
d String
s
          fallBack :: Pixel
fallBack = Display -> ScreenNumber -> Pixel
blackPixel Display
d (Display -> ScreenNumber
defaultScreen Display
d)

-- | Convert a @Pixel@ into a @String@.
pixelToString :: (MonadIO m) => Display -> Pixel -> m String
pixelToString :: Display -> Pixel -> m String
pixelToString Display
d Pixel
p = do
    let cm :: Pixel
cm = Display -> ScreenNumber -> Pixel
defaultColormap Display
d (Display -> ScreenNumber
defaultScreen Display
d)
    (Color Pixel
_ Word16
r Word16
g Word16
b Word8
_) <- IO Color -> m Color
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (Display -> Pixel -> Color -> IO Color
queryColor Display
d Pixel
cm (Color -> IO Color) -> Color -> IO Color
forall a b. (a -> b) -> a -> b
$ Pixel -> Word16 -> Word16 -> Word16 -> Word8 -> Color
Color Pixel
p Word16
0 Word16
0 Word16
0 Word8
0)
    String -> m String
forall (m :: * -> *) a. Monad m => a -> m a
return (String
"#" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Word16 -> String
hex Word16
r String -> String -> String
forall a. [a] -> [a] -> [a]
++ Word16 -> String
hex Word16
g String -> String -> String
forall a. [a] -> [a] -> [a]
++ Word16 -> String
hex Word16
b)
  where
    -- NOTE: The @Color@ type has 16-bit values for red, green, and
    -- blue, even though the actual type in X is only 8 bits wide.  It
    -- seems that the upper and lower 8-bit sections of the @Word16@
    -- values are the same.  So, we just discard the lower 8 bits.
    hex :: Word16 -> String
hex = String -> Word16 -> String
forall r. PrintfType r => String -> r
printf String
"%02x" (Word16 -> String) -> (Word16 -> Word16) -> Word16 -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word16 -> Int -> Word16
forall a. Bits a => a -> Int -> a
`shiftR` Int
8)

econst :: a -> IOException -> a
econst :: a -> IOException -> a
econst = a -> IOException -> a
forall a b. a -> b -> a
const

-- | 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 :: String -> X FontStruct
initCoreFont String
s = do
  Display
d <- (XConf -> Display) -> X Display
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XConf -> Display
display
  IO FontStruct -> X FontStruct
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO FontStruct -> X FontStruct) -> IO FontStruct -> X FontStruct
forall a b. (a -> b) -> a -> b
$ IO FontStruct -> (IOException -> IO FontStruct) -> IO FontStruct
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
E.catch (Display -> IO FontStruct
getIt Display
d) (Display -> IOException -> IO FontStruct
fallBack Display
d)
      where getIt :: Display -> IO FontStruct
getIt    Display
d = Display -> String -> IO FontStruct
loadQueryFont Display
d String
s
            fallBack :: Display -> IOException -> IO FontStruct
fallBack Display
d = IO FontStruct -> IOException -> IO FontStruct
forall a. a -> IOException -> a
econst (IO FontStruct -> IOException -> IO FontStruct)
-> IO FontStruct -> IOException -> IO FontStruct
forall a b. (a -> b) -> a -> b
$ Display -> String -> IO FontStruct
loadQueryFont Display
d String
"-misc-fixed-*-*-*-*-10-*-*-*-*-*-*-*"

releaseCoreFont :: FontStruct -> X ()
releaseCoreFont :: FontStruct -> X ()
releaseCoreFont FontStruct
fs = do
  Display
d <- (XConf -> Display) -> X Display
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XConf -> Display
display
  IO () -> X ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> X ()) -> IO () -> X ()
forall a b. (a -> b) -> a -> b
$ Display -> FontStruct -> IO ()
freeFont Display
d FontStruct
fs

initUtf8Font :: String -> X FontSet
initUtf8Font :: String -> X FontSet
initUtf8Font String
s = do
  Display
d <- (XConf -> Display) -> X Display
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XConf -> Display
display
  ([String]
_,String
_,FontSet
fs) <- IO ([String], String, FontSet) -> X ([String], String, FontSet)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO ([String], String, FontSet) -> X ([String], String, FontSet))
-> IO ([String], String, FontSet) -> X ([String], String, FontSet)
forall a b. (a -> b) -> a -> b
$ IO ([String], String, FontSet)
-> (IOException -> IO ([String], String, FontSet))
-> IO ([String], String, FontSet)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
E.catch (Display -> IO ([String], String, FontSet)
getIt Display
d) (Display -> IOException -> IO ([String], String, FontSet)
fallBack Display
d)
  FontSet -> X FontSet
forall (m :: * -> *) a. Monad m => a -> m a
return FontSet
fs
      where getIt :: Display -> IO ([String], String, FontSet)
getIt    Display
d = Display -> String -> IO ([String], String, FontSet)
createFontSet Display
d String
s
            fallBack :: Display -> IOException -> IO ([String], String, FontSet)
fallBack Display
d = IO ([String], String, FontSet)
-> IOException -> IO ([String], String, FontSet)
forall a. a -> IOException -> a
econst (IO ([String], String, FontSet)
 -> IOException -> IO ([String], String, FontSet))
-> IO ([String], String, FontSet)
-> IOException
-> IO ([String], String, FontSet)
forall a b. (a -> b) -> a -> b
$ Display -> String -> IO ([String], String, FontSet)
createFontSet Display
d String
"-misc-fixed-*-*-*-*-10-*-*-*-*-*-*-*"

releaseUtf8Font :: FontSet -> X ()
releaseUtf8Font :: FontSet -> X ()
releaseUtf8Font FontSet
fs = do
  Display
d <- (XConf -> Display) -> X Display
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XConf -> Display
display
  IO () -> X ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> X ()) -> IO () -> X ()
forall a b. (a -> b) -> a -> b
$ Display -> FontSet -> IO ()
freeFontSet Display
d FontSet
fs

-- | When initXMF gets a font name that starts with 'xft:' it switches to the Xft backend
-- Example: 'xft: Sans-10'
initXMF :: String -> X XMonadFont
initXMF :: String -> X XMonadFont
initXMF String
s =
#ifdef XFT
  if String
xftPrefix String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
s then
     do Display
dpy <- (XConf -> Display) -> X Display
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XConf -> Display
display
        XftFont
xftdraw <- IO XftFont -> X XftFont
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO XftFont -> X XftFont) -> IO XftFont -> X XftFont
forall a b. (a -> b) -> a -> b
$ Display -> Screen -> String -> IO XftFont
xftFontOpen Display
dpy (Display -> Screen
defaultScreenOfDisplay Display
dpy) (Int -> String -> String
forall a. Int -> [a] -> [a]
drop (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
xftPrefix) String
s)
        XMonadFont -> X XMonadFont
forall (m :: * -> *) a. Monad m => a -> m a
return (XftFont -> XMonadFont
Xft XftFont
xftdraw)
  else
#endif
      FontSet -> XMonadFont
Utf8 (FontSet -> XMonadFont) -> X FontSet -> X XMonadFont
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> X FontSet
initUtf8Font String
s
#ifdef XFT
  where xftPrefix :: String
xftPrefix = String
"xft:"
#endif

releaseXMF :: XMonadFont -> X ()
#ifdef XFT
releaseXMF :: XMonadFont -> X ()
releaseXMF (Xft XftFont
xftfont) = do
  Display
dpy <- (XConf -> Display) -> X Display
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XConf -> Display
display
  IO () -> X ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> X ()) -> IO () -> X ()
forall a b. (a -> b) -> a -> b
$ Display -> XftFont -> IO ()
xftFontClose Display
dpy XftFont
xftfont
#endif
releaseXMF (Utf8 FontSet
fs) = FontSet -> X ()
releaseUtf8Font FontSet
fs
releaseXMF (Core FontStruct
fs) = FontStruct -> X ()
releaseCoreFont FontStruct
fs


textWidthXMF :: MonadIO m => Display -> XMonadFont -> String -> m Int
textWidthXMF :: Display -> XMonadFont -> String -> m Int
textWidthXMF Display
_   (Utf8 FontSet
fs) String
s = Int -> m Int
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> m Int) -> Int -> m Int
forall a b. (a -> b) -> a -> b
$ Int32 -> Int
forall a b. (Integral a, Num b) => a -> b
fi (Int32 -> Int) -> Int32 -> Int
forall a b. (a -> b) -> a -> b
$ FontSet -> String -> Int32
wcTextEscapement FontSet
fs String
s
textWidthXMF Display
_   (Core FontStruct
fs) String
s = Int -> m Int
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> m Int) -> Int -> m Int
forall a b. (a -> b) -> a -> b
$ Int32 -> Int
forall a b. (Integral a, Num b) => a -> b
fi (Int32 -> Int) -> Int32 -> Int
forall a b. (a -> b) -> a -> b
$ FontStruct -> String -> Int32
textWidth FontStruct
fs String
s
#ifdef XFT
textWidthXMF Display
dpy (Xft XftFont
xftdraw) String
s = IO Int -> m Int
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Int -> m Int) -> IO Int -> m Int
forall a b. (a -> b) -> a -> b
$ do
    XGlyphInfo
gi <- Display -> XftFont -> String -> IO XGlyphInfo
xftTextExtents Display
dpy XftFont
xftdraw 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
$ XGlyphInfo -> Int
xglyphinfo_xOff XGlyphInfo
gi
#endif

textExtentsXMF :: MonadIO m => XMonadFont -> String -> m (Int32,Int32)
textExtentsXMF :: XMonadFont -> String -> m (Int32, Int32)
textExtentsXMF (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
fi (Int32 -> Int32) -> Int32 -> Int32
forall a b. (a -> b) -> a -> b
$ - (Rectangle -> Int32
rect_y Rectangle
rl)
      descent :: Int32
descent = ScreenNumber -> Int32
forall a b. (Integral a, Num b) => a -> b
fi (ScreenNumber -> Int32) -> ScreenNumber -> Int32
forall a b. (a -> b) -> a -> b
$ Rectangle -> ScreenNumber
rect_height Rectangle
rl ScreenNumber -> ScreenNumber -> ScreenNumber
forall a. Num a => a -> a -> a
+ Int32 -> ScreenNumber
forall a b. (Integral a, Num b) => a -> b
fi (Rectangle -> Int32
rect_y Rectangle
rl)
  (Int32, Int32) -> m (Int32, Int32)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int32
ascent, Int32
descent)
textExtentsXMF (Core FontStruct
fs) String
s = do
  let (FontDirection
_,Int32
a,Int32
d,CharStruct
_) = FontStruct -> String -> (FontDirection, Int32, Int32, CharStruct)
textExtents FontStruct
fs String
s
  (Int32, Int32) -> m (Int32, Int32)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int32
a,Int32
d)
#ifdef XFT
textExtentsXMF (Xft XftFont
xftfont) String
_ = IO (Int32, Int32) -> m (Int32, Int32)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO (Int32, Int32) -> m (Int32, Int32))
-> IO (Int32, Int32) -> m (Int32, Int32)
forall a b. (a -> b) -> a -> b
$ do
  Int32
ascent  <- Int -> Int32
forall a b. (Integral a, Num b) => a -> b
fi (Int -> Int32) -> IO Int -> IO Int32
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> XftFont -> IO Int
xftfont_ascent  XftFont
xftfont
  Int32
descent <- Int -> Int32
forall a b. (Integral a, Num b) => a -> b
fi (Int -> Int32) -> IO Int -> IO Int32
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> XftFont -> IO Int
xftfont_descent XftFont
xftfont
  (Int32, Int32) -> IO (Int32, Int32)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int32
ascent, Int32
descent)
#endif

-- | String position
data Align = AlignCenter | AlignRight | AlignLeft | AlignRightOffset Int
                deriving (Int -> Align -> String -> String
[Align] -> String -> String
Align -> String
(Int -> Align -> String -> String)
-> (Align -> String) -> ([Align] -> String -> String) -> Show Align
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [Align] -> String -> String
$cshowList :: [Align] -> String -> String
show :: Align -> String
$cshow :: Align -> String
showsPrec :: Int -> Align -> String -> String
$cshowsPrec :: Int -> Align -> String -> String
Show, ReadPrec [Align]
ReadPrec Align
Int -> ReadS Align
ReadS [Align]
(Int -> ReadS Align)
-> ReadS [Align]
-> ReadPrec Align
-> ReadPrec [Align]
-> Read Align
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Align]
$creadListPrec :: ReadPrec [Align]
readPrec :: ReadPrec Align
$creadPrec :: ReadPrec Align
readList :: ReadS [Align]
$creadList :: ReadS [Align]
readsPrec :: Int -> ReadS Align
$creadsPrec :: Int -> ReadS Align
Read)

-- | 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 :: Display
-> XMonadFont -> Rectangle -> Align -> String -> m (Int32, Int32)
stringPosition Display
dpy XMonadFont
fs (Rectangle Int32
_ Int32
_ ScreenNumber
w ScreenNumber
h) Align
al String
s = do
  Int
width <- Display -> XMonadFont -> String -> m Int
forall (m :: * -> *).
MonadIO m =>
Display -> XMonadFont -> String -> m Int
textWidthXMF Display
dpy XMonadFont
fs String
s
  (Int32
a,Int32
d) <- XMonadFont -> String -> m (Int32, Int32)
forall (m :: * -> *).
MonadIO m =>
XMonadFont -> String -> m (Int32, Int32)
textExtentsXMF XMonadFont
fs String
s
  let y :: Int32
y = ScreenNumber -> Int32
forall a b. (Integral a, Num b) => a -> b
fi (ScreenNumber -> Int32) -> ScreenNumber -> Int32
forall a b. (a -> b) -> a -> b
$ ((ScreenNumber
h ScreenNumber -> ScreenNumber -> ScreenNumber
forall a. Num a => a -> a -> a
- Int32 -> ScreenNumber
forall a b. (Integral a, Num b) => a -> b
fi (Int32
a Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
+ Int32
d)) ScreenNumber -> ScreenNumber -> ScreenNumber
forall a. Integral a => a -> a -> a
`div` ScreenNumber
2) ScreenNumber -> ScreenNumber -> ScreenNumber
forall a. Num a => a -> a -> a
+ Int32 -> ScreenNumber
forall a b. (Integral a, Num b) => a -> b
fi Int32
a;
      x :: Int32
x = case Align
al of
            Align
AlignCenter -> ScreenNumber -> Int32
forall a b. (Integral a, Num b) => a -> b
fi (ScreenNumber
w ScreenNumber -> ScreenNumber -> ScreenNumber
forall a. Integral a => a -> a -> a
`div` ScreenNumber
2) Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
- Int -> Int32
forall a b. (Integral a, Num b) => a -> b
fi (Int
width Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2)
            Align
AlignLeft   -> Int32
1
            Align
AlignRight  -> ScreenNumber -> Int32
forall a b. (Integral a, Num b) => a -> b
fi (ScreenNumber
w ScreenNumber -> ScreenNumber -> ScreenNumber
forall a. Num a => a -> a -> a
- (Int -> ScreenNumber
forall a b. (Integral a, Num b) => a -> b
fi Int
width ScreenNumber -> ScreenNumber -> ScreenNumber
forall a. Num a => a -> a -> a
+ ScreenNumber
1));
            AlignRightOffset Int
offset -> ScreenNumber -> Int32
forall a b. (Integral a, Num b) => a -> b
fi (ScreenNumber
w ScreenNumber -> ScreenNumber -> ScreenNumber
forall a. Num a => a -> a -> a
- (Int -> ScreenNumber
forall a b. (Integral a, Num b) => a -> b
fi Int
width ScreenNumber -> ScreenNumber -> ScreenNumber
forall a. Num a => a -> a -> a
+ ScreenNumber
1)) Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
- Int -> Int32
forall a b. (Integral a, Num b) => a -> b
fi Int
offset;
  (Int32, Int32) -> m (Int32, Int32)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int32
x,Int32
y)

printStringXMF :: (Functor m, MonadIO m) => Display -> Drawable -> XMonadFont -> GC -> String -> String
            -> Position -> Position -> String  -> m ()
printStringXMF :: Display
-> Pixel
-> XMonadFont
-> GC
-> String
-> String
-> Int32
-> Int32
-> String
-> m ()
printStringXMF Display
d Pixel
p (Core FontStruct
fs) GC
gc String
fc String
bc Int32
x Int32
y String
s = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    Display -> GC -> Pixel -> IO ()
setFont Display
d GC
gc (Pixel -> IO ()) -> Pixel -> IO ()
forall a b. (a -> b) -> a -> b
$ FontStruct -> Pixel
fontFromFontStruct FontStruct
fs
    [Pixel
fc',Pixel
bc'] <- (String -> IO Pixel) -> [String] -> IO [Pixel]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Display -> String -> IO Pixel
forall (m :: * -> *).
(Functor m, MonadIO m) =>
Display -> String -> m Pixel
stringToPixel Display
d) [String
fc,String
bc]
    Display -> GC -> Pixel -> IO ()
setForeground Display
d GC
gc Pixel
fc'
    Display -> GC -> Pixel -> IO ()
setBackground Display
d GC
gc Pixel
bc'
    Display -> Pixel -> GC -> Int32 -> Int32 -> String -> IO ()
drawImageString Display
d Pixel
p GC
gc Int32
x Int32
y String
s
printStringXMF Display
d Pixel
p (Utf8 FontSet
fs) GC
gc String
fc String
bc Int32
x Int32
y String
s = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    [Pixel
fc',Pixel
bc'] <- (String -> IO Pixel) -> [String] -> IO [Pixel]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Display -> String -> IO Pixel
forall (m :: * -> *).
(Functor m, MonadIO m) =>
Display -> String -> m Pixel
stringToPixel Display
d) [String
fc,String
bc]
    Display -> GC -> Pixel -> IO ()
setForeground Display
d GC
gc Pixel
fc'
    Display -> GC -> Pixel -> IO ()
setBackground Display
d GC
gc Pixel
bc'
    IO () -> IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Display
-> Pixel -> FontSet -> GC -> Int32 -> Int32 -> String -> IO ()
wcDrawImageString Display
d Pixel
p FontSet
fs GC
gc Int32
x Int32
y String
s
#ifdef XFT
printStringXMF Display
dpy Pixel
drw fs :: XMonadFont
fs@(Xft XftFont
font) GC
gc String
fc String
bc Int32
x Int32
y String
s = do
  let screen :: Screen
screen   = Display -> Screen
defaultScreenOfDisplay Display
dpy
      colormap :: Pixel
colormap = Screen -> Pixel
defaultColormapOfScreen Screen
screen
      visual :: Visual
visual   = Screen -> Visual
defaultVisualOfScreen Screen
screen
  Pixel
bcolor <- Display -> String -> m Pixel
forall (m :: * -> *).
(Functor m, MonadIO m) =>
Display -> String -> m Pixel
stringToPixel Display
dpy String
bc
  (Int32
a,Int32
d)  <- XMonadFont -> String -> m (Int32, Int32)
forall (m :: * -> *).
MonadIO m =>
XMonadFont -> String -> m (Int32, Int32)
textExtentsXMF XMonadFont
fs String
s
  XGlyphInfo
gi <- IO XGlyphInfo -> m XGlyphInfo
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO XGlyphInfo -> m XGlyphInfo) -> IO XGlyphInfo -> m XGlyphInfo
forall a b. (a -> b) -> a -> b
$ Display -> XftFont -> String -> IO XGlyphInfo
xftTextExtents Display
dpy XftFont
font String
s
  IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Display -> GC -> Pixel -> IO ()
setForeground Display
dpy GC
gc Pixel
bcolor
  IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Display
-> Pixel
-> GC
-> Int32
-> Int32
-> ScreenNumber
-> ScreenNumber
-> IO ()
fillRectangle Display
dpy Pixel
drw GC
gc (Int32
x Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
- Int -> Int32
forall a b. (Integral a, Num b) => a -> b
fi (XGlyphInfo -> Int
xglyphinfo_x XGlyphInfo
gi))
                                (Int32
y Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
- Int32 -> Int32
forall a b. (Integral a, Num b) => a -> b
fi Int32
a)
                                (Int -> ScreenNumber
forall a b. (Integral a, Num b) => a -> b
fi (Int -> ScreenNumber) -> Int -> ScreenNumber
forall a b. (a -> b) -> a -> b
$ XGlyphInfo -> Int
xglyphinfo_xOff XGlyphInfo
gi)
                                (Int32 -> ScreenNumber
forall a b. (Integral a, Num b) => a -> b
fi (Int32 -> ScreenNumber) -> Int32 -> ScreenNumber
forall a b. (a -> b) -> a -> b
$ Int32
a Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
+ Int32
d)
  IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Display -> Pixel -> Visual -> Pixel -> (XftDraw -> IO ()) -> IO ()
forall a.
Display -> Pixel -> Visual -> Pixel -> (XftDraw -> IO a) -> IO a
withXftDraw Display
dpy Pixel
drw Visual
visual Pixel
colormap ((XftDraw -> IO ()) -> IO ()) -> (XftDraw -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$
         \XftDraw
draw -> Display
-> Visual -> Pixel -> String -> (XftColor -> IO ()) -> IO ()
forall a.
Display -> Visual -> Pixel -> String -> (XftColor -> IO a) -> IO a
withXftColorName Display
dpy Visual
visual Pixel
colormap String
fc ((XftColor -> IO ()) -> IO ()) -> (XftColor -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$
                   \XftColor
color -> XftDraw -> XftColor -> XftFont -> Int32 -> Int32 -> String -> IO ()
forall a1 a2.
(Integral a1, Integral a2) =>
XftDraw -> XftColor -> XftFont -> a1 -> a2 -> String -> IO ()
xftDrawString XftDraw
draw XftColor
color XftFont
font Int32
x Int32
y String
s
#endif