gnu: home: services: fontutils: Add support for SXML fragments.

* gnu/home/services/fontutils.scm (add-fontconfig-config-file): Add
support for adding arbitrary SXML configuration into fonts.conf;
* doc/guix.texi (Fonts Services): Update the documentation.

Signed-off-by: Ludovic Courtès <ludo@gnu.org>

2 files changed, 41 insertions, 13 deletions

diff --git a/doc/guix.texi b/doc/guix.texi
index ef2b78baeb..27fc3b1689 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -43084,8 +43084,10 @@ library is used by many applications to access fonts on the system.
 
 @defvar home-fontconfig-service-type
 This is the service type for generating configurations for Fontconfig.
-Its associated value is a list of strings (or gexps) pointing to fonts
-locations.
+Its associated value is a list of either strings (or gexps) pointing to
+fonts locations, or SXML (@pxref{SXML,,, guile, GNU Guile Reference
+Manual}) fragments to be converted into XML and put inside the main
+@code{fontconfig} node.
 
 Generally, it is better to extend this service than to directly
 configure it, as its default value is the default Guix Home's profile
@@ -43093,13 +43095,17 @@ font installation path (@file{~/.guix-home/profile/share/fonts}).  If
 you configure this service directly, be sure to include the above
 directory.
 
-A typical extension for adding an additional font directory might look
-like this:
+A typical extension for adding an additional font directory and setting
+a font as the default monospace font might look like this:
 
 @lisp
 (simple-service 'additional-fonts-service
                 home-fontconfig-service-type
-                (list "~/.nix-profile/share/fonts"))
+                (list "~/.nix-profile/share/fonts"
+                      '(alias
+                        (family "monospace")
+                        (prefer
+                         (family "Liberation Mono")))))
 @end lisp
 @end defvar
 
diff --git a/gnu/home/services/fontutils.scm b/gnu/home/services/fontutils.scm
index 3399cb7ec8..0e60bc2035 100644
--- a/gnu/home/services/fontutils.scm
+++ b/gnu/home/services/fontutils.scm
@@ -2,6 +2,7 @@
 ;;; Copyright © 2021 Andrew Tropin <andrew@trop.in>
 ;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz>
 ;;; Copyright © 2023 Giacomo Leidi <goodoldpaul@autistici.org>
+;;; Copyright © 2023 Andrew Patterson <andrewpatt7@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -23,6 +24,8 @@
   #:use-module (gnu packages fontutils)
   #:use-module (guix gexp)
   #:use-module (srfi srfi-1)
+  #:use-module (ice-9 match)
+  #:use-module (sxml simple)
 
   #:export (home-fontconfig-service-type))
 
@@ -35,17 +38,36 @@
 ;;;
 ;;; Code:
 
-(define (add-fontconfig-config-file directories)
+(define (write-fontconfig-doctype)
+  "Prints fontconfig's DOCTYPE to current-output-port."
+  ;; This is necessary because SXML doesn't seem to have a way to represent a doctype,
+  ;; but sxml->xml /does/ currently call any thunks in the SXML with the XML output port
+  ;; as current-output-port, allowing the output to include arbitrary text instead of
+  ;; just properly quoted XML.
+  (format #t "<!DOCTYPE fontconfig SYSTEM 'fonts.dtd'>"))
+
+(define (config->sxml config)
+  "Converts a <home-fontconfig-configuration> record into the SXML representation
+of fontconfig's fonts.conf file."
+  (define (snippets->sxml snippet)
+    (match snippet
+      ((or (? string? dir)
+           (? gexp? dir))
+       `(dir ,dir))
+      ((? list?)
+       snippet)))
+  `(*TOP* (*PI* xml "version='1.0'")
+          ,write-fontconfig-doctype
+          (fontconfig
+           ,@(map snippets->sxml config))))
+
+(define (add-fontconfig-config-file config)
   `(("fontconfig/fonts.conf"
      ,(mixed-text-file
        "fonts.conf"
-       (apply string-append
-              `("<?xml version='1.0'?>
-<!DOCTYPE fontconfig SYSTEM 'fonts.dtd'>
-<fontconfig>\n" ,@(map (lambda (directory)
-                         (string-append "  <dir>" directory "</dir>\n"))
-                       directories)
-                "</fontconfig>\n"))))))
+       (call-with-output-string
+         (lambda (port)
+           (sxml->xml (config->sxml config) port)))))))
 
 (define (regenerate-font-cache-gexp _)
   `(("profile/share/fonts"