{-# LANGUAGE CPP #-}
----------------------------------------------------------------------------
-- |
-- 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
    , pixelToString
    , fi
    ) where

import XMonad
import Foreign
import Control.Applicative
import Control.Exception as E
import Data.Maybe
import Data.Bits (shiftR)
import Text.Printf (printf)

#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
                | 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 d :: Display
d s :: 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 -> Pixel -> Pixel
blackPixel Display
d (Display -> Pixel
defaultScreen Display
d)

-- | Convert a @Pixel@ into a @String@.
pixelToString :: (MonadIO m) => Display -> Pixel -> m String
pixelToString :: Display -> Pixel -> m String
pixelToString d :: Display
d p :: Pixel
p = do
    let cm :: Pixel
cm = Display -> Pixel -> Pixel
defaultColormap Display
d (Display -> Pixel
defaultScreen Display
d)
    (Color _ r :: Word16
r g :: Word16
g b :: Word16
b _) <- 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 0 0 0 0)
    String -> m String
forall (m :: * -> *) a. Monad m => a -> m a
return ("#" 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 "%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` 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 s :: 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    d :: Display
d = Display -> String -> IO FontStruct
loadQueryFont Display
d String
s
            fallBack :: Display -> IOException -> IO FontStruct
fallBack d :: 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 "-misc-fixed-*-*-*-*-10-*-*-*-*-*-*-*"

releaseCoreFont :: FontStruct -> X ()
releaseCoreFont :: FontStruct -> X ()
releaseCoreFont fs :: 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 s :: String
s = do
  Display
d <- (XConf -> Display) -> X Display
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XConf -> Display
display
  (_,_,fs :: 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    d :: Display
d = Display -> String -> IO ([String], String, FontSet)
createFontSet Display
d String
s
            fallBack :: Display -> IOException -> IO ([String], String, FontSet)
fallBack d :: 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 "-misc-fixed-*-*-*-*-10-*-*-*-*-*-*-*"

releaseUtf8Font :: FontSet -> X ()
releaseUtf8Font :: FontSet -> X ()
releaseUtf8Font fs :: 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 s :: 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) -> X FontSet -> X XMonadFont
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FontSet -> XMonadFont
Utf8 (X FontSet -> X XMonadFont) -> X FontSet -> X XMonadFont
forall a b. (a -> b) -> a -> b
$ String -> X FontSet
initUtf8Font String
s
#ifdef XFT
  where xftPrefix :: String
xftPrefix = "xft:"
#endif

releaseXMF :: XMonadFont -> X ()
#ifdef XFT
releaseXMF :: XMonadFont -> X ()
releaseXMF (Xft xftfont :: 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 fs :: FontSet
fs) = FontSet -> X ()
releaseUtf8Font FontSet
fs
releaseXMF (Core fs :: FontStruct
fs) = FontStruct -> X ()
releaseCoreFont FontStruct
fs


textWidthXMF :: MonadIO m => Display -> XMonadFont -> String -> m Int
textWidthXMF :: Display -> XMonadFont -> String -> m Int
textWidthXMF _   (Utf8 fs :: FontSet
fs) s :: 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 _   (Core fs :: FontStruct
fs) s :: 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 dpy :: Display
dpy (Xft xftdraw :: XftFont
xftdraw) s :: 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 fs :: FontSet
fs) s :: String
s = do
  let (_,rl :: 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 = Pixel -> Int32
forall a b. (Integral a, Num b) => a -> b
fi (Pixel -> Int32) -> Pixel -> Int32
forall a b. (a -> b) -> a -> b
$ Rectangle -> Pixel
rect_height Rectangle
rl Pixel -> Pixel -> Pixel
forall a. Num a => a -> a -> a
+ (Int32 -> Pixel
forall a b. (Integral a, Num b) => a -> b
fi (Int32 -> Pixel) -> Int32 -> Pixel
forall a b. (a -> b) -> a -> b
$ 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 fs :: FontStruct
fs) s :: String
s = do
  let (_,a :: Int32
a,d :: Int32
d,_) = 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
xftfont) _ = 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
`fmap` 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
`fmap` 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 dpy :: Display
dpy fs :: XMonadFont
fs (Rectangle _ _ w :: Pixel
w h :: Pixel
h) al :: Align
al s :: 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
  (a :: Int32
a,d :: 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 = Pixel -> Int32
forall a b. (Integral a, Num b) => a -> b
fi (Pixel -> Int32) -> Pixel -> Int32
forall a b. (a -> b) -> a -> b
$ ((Pixel
h Pixel -> Pixel -> Pixel
forall a. Num a => a -> a -> a
- Int32 -> Pixel
forall a b. (Integral a, Num b) => a -> b
fi (Int32
a Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
+ Int32
d)) Pixel -> Pixel -> Pixel
forall a. Integral a => a -> a -> a
`div` 2) Pixel -> Pixel -> Pixel
forall a. Num a => a -> a -> a
+ Int32 -> Pixel
forall a b. (Integral a, Num b) => a -> b
fi Int32
a;
      x :: Int32
x = case Align
al of
            AlignCenter -> Pixel -> Int32
forall a b. (Integral a, Num b) => a -> b
fi (Pixel
w Pixel -> Pixel -> Pixel
forall a. Integral a => a -> a -> a
`div` 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` 2)
            AlignLeft   -> 1
            AlignRight  -> Pixel -> Int32
forall a b. (Integral a, Num b) => a -> b
fi (Pixel
w Pixel -> Pixel -> Pixel
forall a. Num a => a -> a -> a
- (Int -> Pixel
forall a b. (Integral a, Num b) => a -> b
fi Int
width Pixel -> Pixel -> Pixel
forall a. Num a => a -> a -> a
+ 1));
            AlignRightOffset offset :: Int
offset -> Pixel -> Int32
forall a b. (Integral a, Num b) => a -> b
fi (Pixel
w Pixel -> Pixel -> Pixel
forall a. Num a => a -> a -> a
- (Int -> Pixel
forall a b. (Integral a, Num b) => a -> b
fi Int
width Pixel -> Pixel -> Pixel
forall a. Num a => a -> a -> a
+ 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 d :: Display
d p :: Pixel
p (Core fs :: FontStruct
fs) gc :: GC
gc fc :: String
fc bc :: String
bc x :: Int32
x y :: Int32
y s :: 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
    [fc' :: Pixel
fc',bc' :: 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 d :: Display
d p :: Pixel
p (Utf8 fs :: FontSet
fs) gc :: GC
gc fc :: String
fc bc :: String
bc x :: Int32
x y :: Int32
y s :: 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
    [fc' :: Pixel
fc',bc' :: 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 dpy :: Display
dpy drw :: Pixel
drw fs :: XMonadFont
fs@(Xft font :: XftFont
font) gc :: GC
gc fc :: String
fc bc :: String
bc x :: Int32
x y :: Int32
y s :: 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
  (a :: Int32
a,d :: 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 -> Pixel -> Pixel -> 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 -> Pixel
forall a b. (Integral a, Num b) => a -> b
fi (Int -> Pixel) -> Int -> Pixel
forall a b. (a -> b) -> a -> b
$ XGlyphInfo -> Int
xglyphinfo_xOff XGlyphInfo
gi)
                                (Int32 -> Pixel
forall a b. (Integral a, Num b) => a -> b
fi (Int32 -> Pixel) -> Int32 -> Pixel
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
$
         \draw :: 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
$
                   \color :: 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

-- | Short-hand for 'fromIntegral'
fi :: (Integral a, Num b) => a -> b
fi :: a -> b
fi = a -> b
forall a b. (Integral a, Num b) => a -> b
fromIntegral