    {-# 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 qualified Data.List.NonEmpty as NE
    import Graphics.X11.Xrender
    import Graphics.X11.Xft
    #endif

    -- Hide the Core Font/Xft switching here
    data XMonadFont = Core FontStruct
                    | Utf8 FontSet
    #ifdef XFT
                    | Xft  (NE.NonEmpty 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 :: forall (m :: * -> *).
    (Functor m, MonadIO m) =>
    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@.
    --
    -- This function removes any alpha channel from the @Pixel@, because X11
    -- mishandles alpha channels and produces black.
    pixelToString :: (MonadIO m) => Display -> Pixel -> m String
    pixelToString :: forall (m :: * -> *). MonadIO m => 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 _ r g 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 Pixel -> Pixel -> Pixel
    forall a. Bits a => a -> a -> a
    .&. Pixel
    0x00FFFFFF) Word16
    0 Word16
    0 Word16
    0 Word8
    0)
        return ("#" ++ hex r ++ hex g ++ hex 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.
        --
        -- (Strictly, X11 supports 16-bit values but no visual supported
        -- by XOrg does. It is still correct to discard the lower bits, as
        -- they are not guaranteed to be meaningful in such visuals.)
        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 :: forall a. 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
      d <- (XConf -> Display) -> X Display
    forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
    asks XConf -> Display
    display
      io $ E.catch (getIt d) (fallBack 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
      d <- (XConf -> Display) -> X Display
    forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
    asks XConf -> Display
    display
      io $ freeFont d fs

    initUtf8Font :: String -> X FontSet
    initUtf8Font :: String -> X FontSet
    initUtf8Font String
    s = do
      d <- (XConf -> Display) -> X Display
    forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
    asks XConf -> Display
    display
      (_,_,fs) <- io $ E.catch (getIt d) (fallBack d)
      return 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
      d <- (XConf -> Display) -> X Display
    forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
    asks XConf -> Display
    display
      io $ freeFontSet d 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 =
    #ifndef XFT
      Utf8 <$> initUtf8Font s
    #else
      if String
    xftPrefix String -> String -> Bool
    forall a. Eq a => [a] -> [a] -> Bool
    `isPrefixOf` String
    s then
         do dpy <- (XConf -> Display) -> X Display
    forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
    asks XConf -> Display
    display
            let fonts = case (Char -> Bool) -> String -> [String]
    wordsBy (Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    == Char
    ',') (Int -> String -> String
    forall a. Int -> [a] -> [a]
    drop (String -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length String
    xftPrefix) String
    s) of
                  []       -> String
    fallback String -> [String] -> NonEmpty String
    forall a. a -> [a] -> NonEmpty a
    :| []  -- NE.singleton only in base 4.15
                  (String
    x : [String]
    xs) -> String
    x String -> [String] -> NonEmpty String
    forall a. a -> [a] -> NonEmpty a
    :| [String]
    xs
            fb <- io $ openFont dpy fallback
            fmap Xft . io $ traverse (\String
    f -> IO XftFont -> (IOException -> IO XftFont) -> IO XftFont
    forall e a. Exception e => IO a -> (e -> IO a) -> IO a
    E.catch (Display -> String -> IO XftFont
    openFont Display
    dpy String
    f) (IO XftFont -> IOException -> IO XftFont
    forall a. a -> IOException -> a
    econst (IO XftFont -> IOException -> IO XftFont)
    -> IO XftFont -> IOException -> IO XftFont
    forall a b. (a -> b) -> a -> b
    $ XftFont -> IO XftFont
    forall a. a -> IO a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure XftFont
    fb))
                                     fonts
      else 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
     where
      xftPrefix :: String
    xftPrefix = String
    "xft:"
      fallback :: String
    fallback  = String
    "xft:monospace"
      openFont :: Display -> String -> IO XftFont
    openFont Display
    dpy String
    str = Display -> Screen -> String -> IO XftFont
    xftFontOpen Display
    dpy (Display -> Screen
    defaultScreenOfDisplay Display
    dpy) String
    str
      wordsBy :: (Char -> Bool) -> String -> [String]
    wordsBy Char -> Bool
    p String
    str = case (Char -> Bool) -> String -> String
    forall a. (a -> Bool) -> [a] -> [a]
    dropWhile Char -> Bool
    p String
    str of
        String
    ""   -> []
        String
    str' -> String
    w String -> [String] -> [String]
    forall a. a -> [a] -> [a]
    : (Char -> Bool) -> String -> [String]
    wordsBy Char -> Bool
    p String
    str''
         where (String
    w, String
    str'') = (Char -> Bool) -> String -> (String, String)
    forall a. (a -> Bool) -> [a] -> ([a], [a])
    break Char -> Bool
    p String
    str'
    #endif

    releaseXMF :: XMonadFont -> X ()
    #ifdef XFT
    releaseXMF :: XMonadFont -> X ()
    releaseXMF (Xft NonEmpty XftFont
    xftfonts) = do
      dpy <- (XConf -> Display) -> X Display
    forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
    asks XConf -> Display
    display
      io $ mapM_ (xftFontClose dpy) xftfonts
    #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 :: forall (m :: * -> *).
    MonadIO m =>
    Display -> XMonadFont -> String -> m Int
    textWidthXMF Display
    _   (Utf8 FontSet
    fs) String
    s = Int -> m Int
    forall a. a -> m a
    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 a. a -> m a
    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 NonEmpty XftFont
    xftdraw) String
    s = IO Int -> m Int
    forall a. IO a -> m a
    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
    #if MIN_VERSION_X11_xft(0, 3, 4)
        gi <- Display -> [XftFont] -> String -> IO XGlyphInfo
    xftTextAccumExtents Display
    dpy (NonEmpty XftFont -> [Item (NonEmpty XftFont)]
    forall l. IsList l => l -> [Item l]
    toList NonEmpty XftFont
    xftdraw) String
    s
    #else
        gi <- xftTextExtents dpy (NE.head xftdraw) s
    #endif
        return $ xglyphinfo_xOff gi
    #endif

    textExtentsXMF :: MonadIO m => XMonadFont -> String -> m (Int32,Int32)
    textExtentsXMF :: forall (m :: * -> *).
    MonadIO m =>
    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 a. a -> m a
    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 a. a -> m a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Int32
    a,Int32
    d)
    #ifdef XFT
    #if MIN_VERSION_X11_xft(0, 3, 4)
    textExtentsXMF (Xft NonEmpty XftFont
    xftfonts) 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
      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
    <$> NonEmpty XftFont -> IO Int
    xftfont_max_ascent  NonEmpty XftFont
    xftfonts
      descent <- fi <$> xftfont_max_descent xftfonts
    #else
    textExtentsXMF (Xft xftfonts) _ = io $ do
      ascent  <- fi <$> xftfont_ascent  (NE.head xftfonts)
      descent <- fi <$> xftfont_descent (NE.head xftfonts)
    #endif
      return (ascent, 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
    $cshowsPrec :: Int -> Align -> String -> String
    showsPrec :: Int -> Align -> String -> String
    $cshow :: Align -> String
    show :: Align -> String
    $cshowList :: [Align] -> String -> String
    showList :: [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
    $creadsPrec :: Int -> ReadS Align
    readsPrec :: Int -> ReadS Align
    $creadList :: ReadS [Align]
    readList :: ReadS [Align]
    $creadPrec :: ReadPrec Align
    readPrec :: ReadPrec Align
    $creadListPrec :: ReadPrec [Align]
    readListPrec :: ReadPrec [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 :: forall (m :: * -> *).
    (Functor m, MonadIO m) =>
    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
      width <- Display -> XMonadFont -> String -> m Int
    forall (m :: * -> *).
    MonadIO m =>
    Display -> XMonadFont -> String -> m Int
    textWidthXMF Display
    dpy XMonadFont
    fs String
    s
      (a,d) <- textExtentsXMF fs s
      let 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 = 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;
      return (x,y)

    printStringXMF :: (Functor m, MonadIO m) => Display -> Drawable -> XMonadFont -> GC -> String -> String
                -> Position -> Position -> String  -> m ()
    printStringXMF :: forall (m :: * -> *).
    (Functor m, MonadIO m) =>
    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
        [fc',bc'] <- (String -> IO Pixel) -> [String] -> IO [Pixel]
    forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
    mapM (Display -> String -> IO Pixel
    forall (m :: * -> *).
    (Functor m, MonadIO m) =>
    Display -> String -> m Pixel
    stringToPixel Display
    d) [String
    fc,String
    bc]
        setForeground d gc fc'
        setBackground d gc bc'
        drawImageString d p gc x y 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
        [fc',bc'] <- (String -> IO Pixel) -> [String] -> IO [Pixel]
    forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
    mapM (Display -> String -> IO Pixel
    forall (m :: * -> *).
    (Functor m, MonadIO m) =>
    Display -> String -> m Pixel
    stringToPixel Display
    d) [String
    fc,String
    bc]
        setForeground d gc fc'
        setBackground d gc bc'
        io $ wcDrawImageString d p fs gc x y s
    #ifdef XFT
    printStringXMF Display
    dpy Pixel
    drw fs :: XMonadFont
    fs@(Xft NonEmpty XftFont
    fonts) 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
      bcolor <- Display -> String -> m Pixel
    forall (m :: * -> *).
    (Functor m, MonadIO m) =>
    Display -> String -> m Pixel
    stringToPixel Display
    dpy String
    bc
      (a,d)  <- textExtentsXMF fs s
    #if MIN_VERSION_X11_xft(0, 3, 4)
      gi <- io $ xftTextAccumExtents dpy (toList fonts) s
    #else
      gi <- io $ xftTextExtents dpy (NE.head fonts) s
    #endif
      io $ setForeground dpy gc bcolor
      io $ fillRectangle dpy drw gc (x - fi (xglyphinfo_x gi))
                                    (y - fi a)
                                    (fi $ xglyphinfo_xOff gi)
                                    (fi $ a + d)
      io $ withXftDraw dpy drw visual colormap $
             \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
    $
    #if MIN_VERSION_X11_xft(0, 3, 4)
                       \XftColor
    color -> XftDraw -> XftColor -> [XftFont] -> Int -> Int -> String -> IO ()
    xftDrawStringFallback XftDraw
    draw XftColor
    color (NonEmpty XftFont -> [Item (NonEmpty XftFont)]
    forall l. IsList l => l -> [Item l]
    toList NonEmpty XftFont
    fonts) (Int32 -> Int
    forall a b. (Integral a, Num b) => a -> b
    fi Int32
    x) (Int32 -> Int
    forall a b. (Integral a, Num b) => a -> b
    fi Int32
    y) String
    s
    #else
                       \color -> xftDrawString draw color (NE.head fonts) x y s
    #endif
    #endif