X.U.Font: Add font-fallback support

This adds basic font-fallback support for X.U.Font, as well as modules
using it, like X.Prompt and X.A.TreeSelect.

In the new system, multiple fonts may be specified with the syntax

    "xft:iosevka-11,FontAwesome-9"

Fixes: https://github.com/xmonad/xmonad-contrib/issues/208

CHANGES.md

@@ -28,6 +28,12 @@
     - Added `transposeChars` to interchange the characters around the
       point and bound it to `C-t` in the Emacs XPKeymaps.
 
+    - Added xft-based font fallback support.  This may be used by
+      appending other fonts to the given string:
+      `xft:iosevka-11,FontAwesome-9`.  Note that this requires
+      `xmonad-contrib` to be compiled with `X11-xft` version 0.3.4 or
+      higher.
+
   * `XMonad.Hooks.WindowSwallowing`
 
     - Fixed windows getting lost when used in conjunction with
@@ -53,6 +59,14 @@
       passed onto the modified layout, even when focus leaves the workspace
       using the modified layout.
 
+  * `XMonad.Actions.TreeSelect`
+
+    - Added xft-based font fallback support.  This may be used by
+      appending other fonts to the given string:
+      `xft:iosevka-11,FontAwesome-9`.  Note that this requires
+      `xmonad-contrib` to be compiled with `X11-xft` version 0.3.4 or
+      higher.
+
 ## 0.17.0 (October 27, 2021)
 
 ### Breaking Changes

XMonad/Actions/TreeSelect.hs

@@ -79,8 +79,9 @@ import XMonad.Hooks.WorkspaceHistory
 import qualified Data.Map as M
 
 #ifdef XFT
-import Graphics.X11.Xft
+import qualified Data.List.NonEmpty as NE
 import Graphics.X11.Xrender
+import Graphics.X11.Xft
 #endif
 
 -- $usage
@@ -648,10 +649,14 @@ drawStringXMF display window visual colormap gc font col x y text = case font of
         setForeground display gc col
         wcDrawImageString display window fnt gc x y text
 #ifdef XFT
-    Xft fnt -> do
+    Xft fnts -> do
         withXftDraw display window visual colormap $
             \ft_draw -> withXftColorValue display visual colormap (fromARGB col) $
-            \ft_color -> xftDrawString ft_draw ft_color fnt x y text
+#if MIN_VERSION_X11_xft(0, 3, 4)
+            \ft_color -> xftDrawStringFallback ft_draw ft_color (NE.toList fnts) (fi x) (fi y) text
+#else
+            \ft_color -> xftDrawString ft_draw ft_color (NE.head fnts) x y text
+#endif
 
 -- | Convert 'Pixel' to 'XRenderColor'
 --

XMonad/Util/Font.hs

@@ -41,15 +41,16 @@ import Control.Exception as E
 import Text.Printf (printf)
 
 #ifdef XFT
-import Graphics.X11.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  XftFont
+                | Xft  (NE.NonEmpty XftFont)
 #endif
 
 -- $usage
@@ -109,34 +110,44 @@ releaseUtf8Font fs = do
 -- Example: 'xft: Sans-10'
 initXMF :: String -> X XMonadFont
 initXMF s =
-#ifdef XFT
+#ifndef XFT
+  Utf8 <$> initUtf8Font s
+#else
   if xftPrefix `isPrefixOf` s then
      do dpy <- asks display
-        xftdraw <- io $ xftFontOpen dpy (defaultScreenOfDisplay dpy) (drop (length xftPrefix) s)
+        let fonts = case wordsBy (== ',') (drop (length xftPrefix) s) of
-        return (Xft xftdraw)
+              []       -> "xft:monospace" :| []  -- NE.singleton only in base 4.15
-  else
+              (x : xs) -> x :| xs
-#endif
+        Xft <$> io (traverse (openFont dpy) fonts)
-      Utf8 <$> initUtf8Font s
+  else Utf8 <$> initUtf8Font s
-#ifdef XFT
+ where
-  where xftPrefix = "xft:"
+  xftPrefix = "xft:"
+  openFont dpy str = xftFontOpen dpy (defaultScreenOfDisplay dpy) str
+  wordsBy p str = case dropWhile p str of
+    ""   -> []
+    str' -> w : wordsBy p str''
+     where (w, str'') = break p str'
 #endif
 
 releaseXMF :: XMonadFont -> X ()
 #ifdef XFT
-releaseXMF (Xft xftfont) = do
+releaseXMF (Xft xftfonts) = do
   dpy <- asks display
-  io $ xftFontClose dpy xftfont
+  io $ mapM_ (xftFontClose dpy) xftfonts
 #endif
 releaseXMF (Utf8 fs) = releaseUtf8Font fs
 releaseXMF (Core fs) = releaseCoreFont fs
 
-
 textWidthXMF :: MonadIO m => Display -> XMonadFont -> String -> m Int
 textWidthXMF _   (Utf8 fs) s = return $ fi $ wcTextEscapement fs s
 textWidthXMF _   (Core fs) s = return $ fi $ textWidth fs s
 #ifdef XFT
 textWidthXMF dpy (Xft xftdraw) s = liftIO $ do
-    gi <- xftTextExtents dpy xftdraw s
+#if MIN_VERSION_X11_xft(0, 3, 4)
+    gi <- xftTextAccumExtents dpy (toList xftdraw) s
+#else
+    gi <- xftTextExtents dpy (NE.head xftdraw) s
+#endif
     return $ xglyphinfo_xOff gi
 #endif
 
@@ -150,9 +161,15 @@ textExtentsXMF (Core fs) s = do
   let (_,a,d,_) = textExtents fs s
   return (a,d)
 #ifdef XFT
-textExtentsXMF (Xft xftfont) _ = io $ do
+#if MIN_VERSION_X11_xft(0, 3, 4)
-  ascent  <- fi <$> xftfont_ascent  xftfont
+textExtentsXMF (Xft xftfonts) _ = io $ do
-  descent <- fi <$> xftfont_descent xftfont
+  ascent  <- fi <$> xftfont_max_ascent  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
 
@@ -188,13 +205,17 @@ printStringXMF d p (Utf8 fs) gc fc bc x y s = io $ do
     setBackground d gc bc'
     io $ wcDrawImageString d p fs gc x y s
 #ifdef XFT
-printStringXMF dpy drw fs@(Xft font) gc fc bc x y s = do
+printStringXMF dpy drw fs@(Xft fonts) gc fc bc x y s = do
   let screen   = defaultScreenOfDisplay dpy
       colormap = defaultColormapOfScreen screen
       visual   = defaultVisualOfScreen screen
   bcolor <- stringToPixel dpy bc
   (a,d)  <- textExtentsXMF fs s
-  gi <- io $ xftTextExtents dpy font 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)
@@ -202,5 +223,9 @@ printStringXMF dpy drw fs@(Xft font) gc fc bc x y s = do
                                 (fi $ a + d)
   io $ withXftDraw dpy drw visual colormap $
          \draw -> withXftColorName dpy visual colormap fc $
-                   \color -> xftDrawString draw color font x y s
+#if MIN_VERSION_X11_xft(0, 3, 4)
+                   \color -> xftDrawStringFallback draw color (toList fonts) (fi x) (fi y) s
+#else
+                   \color -> xftDrawString draw color (NE.head fonts) x y s
+#endif
 #endif