    {-# 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 -> 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 d :: Display
    d p :: Pixel
    p = do
        let cm :: Pixel
    cm = Display -> ScreenNumber -> Pixel
    defaultColormap Display
    d (Display -> ScreenNumber
    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 = 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 (Int32 -> ScreenNumber) -> Int32 -> ScreenNumber
    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 :: ScreenNumber
    w h :: ScreenNumber
    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 = 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` 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
                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` 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  -> 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
    + 1));
                AlignRightOffset offset :: 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
    + 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
    -> 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
    $
             \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