[bug#57963] [PATCH v5 2/2] home: services: Support user's fontconfig configuration.

[Taiju HIGASHI <higashi@taiju.info>]

* gnu/home/services/fontutils.scm (add-fontconfig-config-file): Support user's
fontconfig configuration.
(home-fontconfig-configuration): New configuration for it.
(string-list, maybe-string, maybe-extra-config-list): New types for it.
(string-list?, extra-config-list?): New predicate procedures for it.
(serialize-string-list, serialize-string, serialize-extra-config-list): New
serialize procedures for it.
(guix-home-font-dir): New variable.
---
 gnu/home/services/fontutils.scm | 89 ++++++++++++++++++++++++++++++---
 1 file changed, 83 insertions(+), 6 deletions(-)

diff --git a/gnu/home/services/fontutils.scm b/gnu/home/services/fontutils.scm
index 6062eaed6a..4b3caf3985 100644
--- a/gnu/home/services/fontutils.scm
+++ b/gnu/home/services/fontutils.scm
@@ -1,6 +1,7 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2021 Andrew Tropin <andrew@trop.in>
 ;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz>
+;;; Copyright © 2022 Taiju HIGASHI <higashi@taiju.info>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -20,9 +21,17 @@
 (define-module (gnu home services fontutils)
   #:use-module (gnu home services)
   #:use-module (gnu packages fontutils)
+  #:use-module (gnu services configuration)
+  #:use-module (guix diagnostics)
   #:use-module (guix gexp)
+  #:use-module (guix i18n)
+  #:use-module (guix records)
+  #:use-module (srfi srfi-1)
+  #:use-module (sxml simple)
+  #:use-module (ice-9 match)
 
-  #:export (home-fontconfig-service-type))
+  #:export (home-fontconfig-service-type
+            home-fontconfig-configuration))
 
 ;;; Commentary:
 ;;;
@@ -33,15 +42,83 @@ (define-module (gnu home services fontutils)
 ;;;
 ;;; Code:
 
-(define (add-fontconfig-config-file he-symlink-path)
+(define (sxml->xml-string sxml)
+  "Serialize the sxml tree @var{tree} as XML. The output will be string."
+  (call-with-output-string
+    (lambda (port)
+      (sxml->xml sxml port))))
+
+(define guix-home-font-dir "~/.guix-home/profile/share/fonts")
+
+(define (string-list? value)
+  (and (pair? value) (every string? value)))
+
+(define (serialize-string-list field-name value)
+  (sxml->xml-string
+   (map
+    (lambda (path) `(dir ,path))
+    (if (member guix-home-font-dir value)
+        value
+        (append (list guix-home-font-dir) value)))))
+
+(define (serialize-string field-name value)
+  (define (serialize type value)
+    (sxml->xml-string
+     `(alias
+       (family ,type)
+       (prefer
+        (family ,value)))))
+  (match (list field-name value)
+    (('default-font-serif-family family)
+     (serialize 'serif family))
+    (('default-font-sans-serif-family family)
+     (serialize 'sans-serif family))
+    (('default-font-monospace-family family)
+     (serialize 'monospace family))))
+
+(define-maybe string)
+
+(define extra-config-list? list?)
+
+(define-maybe extra-config-list)
+
+(define (serialize-extra-config-list field-name value)
+  (sxml->xml-string
+   (map (match-lambda
+          ((? pair? sxml) sxml)
+          ((? string? xml) (xml->sxml xml))
+          (else
+           (raise (formatted-message
+                   (G_ "'extra-config' type must be xml string or sxml list, was given: ~a")
+                   value))))
+        value)))
+
+(define-configuration home-fontconfig-configuration
+  (font-directories
+   (string-list (list guix-home-font-dir))
+   "The directory list that provides fonts.")
+  (default-font-serif-family
+    maybe-string
+    "The preffered default fonts of serif.")
+  (default-font-sans-serif-family
+    maybe-string
+    "The preffered default fonts of sans-serif.")
+  (default-font-monospace-family
+    maybe-string
+    "The preffered default fonts of monospace.")
+  (extra-config
+   maybe-extra-config-list
+   "Extra configuration values to append to the fonts.conf."))
+
+(define (add-fontconfig-config-file user-config)
   `(("fontconfig/fonts.conf"
      ,(mixed-text-file
        "fonts.conf"
        "<?xml version='1.0'?>
 <!DOCTYPE fontconfig SYSTEM 'fonts.dtd'>
-<fontconfig>
-  <dir>~/.guix-home/profile/share/fonts</dir>
-</fontconfig>"))))
+<fontconfig>"
+       (serialize-configuration user-config home-fontconfig-configuration-fields)
+       "</fontconfig>\n"))))
 
 (define (regenerate-font-cache-gexp _)
   `(("profile/share/fonts"
@@ -59,7 +136,7 @@ (define home-fontconfig-service-type
                        (service-extension
                         home-profile-service-type
                         (const (list fontconfig)))))
-                (default-value #f)
+                (default-value (home-fontconfig-configuration))
                 (description
                  "Provides configuration file for fontconfig and make
 fc-* utilities aware of font packages installed in Guix Home's profile.")))
-- 
2.37.3