gnu: Merge xorg configurations when extending.

Configuration for xorg is embedded in the various display-manager
configuration records, and extension support is factored out into the
`handle-xorg-configuration' macro.  However, the extension mechanism replaces
the existing xorg-configuration with the supplied one, making it impossible to
compose configuration from multiple sources.  This patch adds a procedure to
merge two xorg-configuration records, and calls it within
handle-xorg-configuration, allowing the config to be built piecemeal.

* gnu/services/xorg.scm (merge-xorg-configurations): New variable.
(handle-xorg-configuration): Merge xorg configs.

Change-Id: I20e9db911eef5d4efe98fdf382f3084e4defc1ba
Signed-off-by: Liliana Marie Prikler <liliana.prikler@gmail.com>

gnu/services/xorg.scm

@@ -16,6 +16,7 @@
 ;;; Copyright © 2023 muradm <mail@muradm.net>
 ;;; Copyright © 2024 Zheng Junjie <873216071@qq.com>
 ;;; Copyright © 2024 Tomas Volf <~@wolfsden.cz>
+;;; Copyright © 2025 Ian Eure <ian@retrospec.tv>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -43,6 +44,7 @@
   #:use-module (gnu system privilege)
   #:use-module (gnu services base)
   #:use-module (gnu services dbus)
+  #:use-module (gnu services desktop)
   #:use-module (gnu packages base)
   #:use-module (gnu packages guile)
   #:use-module (gnu packages xorg)
@@ -194,6 +196,8 @@ the first one in the list is loaded."
   ;; Default command-line arguments for X.
   '("-nolisten" "tcp"))
 
+(define %default-xorg-server xorg-server)
+
 ;; Configuration of an Xorg server.
 (define-record-type* <xorg-configuration>
   xorg-configuration make-xorg-configuration
@@ -217,10 +221,42 @@ the first one in the list is loaded."
   (extra-config     xorg-configuration-extra-config ;list of strings
                     (default '()))
   (server           xorg-configuration-server     ;file-like
-                    (default xorg-server))
+                    (default %default-xorg-server))
   (server-arguments xorg-configuration-server-arguments ;list of strings
                     (default %default-xorg-server-arguments)))
 
+(define (merge-xorg-configurations configs)
+  ;; Find whichever config has a non-default Xorg server.
+  (let ((config-with-server
+         (or
+          (find
+           (lambda (config)
+             (or (not (eq? %default-xorg-server
+                           (xorg-configuration-server config)))
+                 (not (eq? %default-xorg-server-arguments
+                           (xorg-configuration-server-arguments config)))))
+           (reverse configs))
+          (xorg-configuration))))
+
+    (xorg-configuration
+      (modules
+       (delete-duplicates (append-map xorg-configuration-modules configs)))
+      (fonts
+       (delete-duplicates (append-map xorg-configuration-fonts configs)))
+      (drivers
+       (delete-duplicates (append-map xorg-configuration-drivers configs)))
+      (resolutions
+       (delete-duplicates (append-map xorg-configuration-resolutions configs)))
+      (extra-config
+       (append-map xorg-configuration-extra-config configs))
+      (keyboard-layout
+       (any xorg-configuration-keyboard-layout (reverse configs)))
+      ;; Use the later config with non-default server for both these fields.
+      (server
+       (xorg-configuration-server config-with-server))
+      (server-arguments
+       (xorg-configuration-server-arguments config-with-server)))))
+
 (define (xorg-configuration->file config)
   "Compute an Xorg configuration file corresponding to CONFIG, an
 <xorg-configuration> record."
@@ -347,7 +383,7 @@ EndSection\n" port)
                   (newline port)))
 
               (for-each (lambda (config)
-                          (display config port))
+                          (display (string-append config "\n\n") port))
                         '#$(xorg-configuration-extra-config config))))))
 
     (computed-file "xserver.conf" build)))
@@ -644,16 +680,12 @@ a `service-extension', as used by `set-xorg-configuration'."
     ((_ configuration-record service-type-definition)
      (service-type
        (inherit service-type-definition)
-       (compose (lambda (extensions)
+       (compose cons*)
-                  (match extensions
+       (extend (lambda (config xorg-configurations)
-                    (() #f)
+                 (configuration-record
-                    ((config . _) config))))
+                  (inherit config)
-       (extend (lambda (config xorg-configuration)
+                  (xorg-configuration
-                 (if xorg-configuration
+                    (merge-xorg-configurations xorg-configurations)))))))))
-                     (configuration-record
-                      (inherit config)
-                      (xorg-configuration xorg-configuration))
-                     config)))))))
 
 (define (xorg-server-profile-service config)
   ;; XXX: profile-service-type only accepts <package> objects.

tests/services/xorg.scm

@@ -0,0 +1,232 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2025 Ian Eure <ian@retrospec.tv>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (tests services xorg)
+  #:use-module (guix diagnostics)
+  #:use-module (guix packages)
+  #:use-module (gnu packages xorg)
+  #:use-module (gnu bootloader)
+  #:use-module (gnu bootloader grub)
+  #:use-module (gnu services)
+  #:use-module (gnu services base)
+  #:use-module (gnu services xorg)
+  #:use-module (gnu system)
+  #:use-module (gnu system keyboard)
+  #:use-module (gnu system file-systems)
+  #:use-module ((srfi srfi-1) #:select (find))
+  #:use-module (srfi srfi-64))
+
+;;; Tests for the (gnu services xorg) module.
+
+(define %config-empty (xorg-configuration))
+
+(define %default-server (xorg-configuration-server %config-empty))
+
+
+
+(test-begin "merge-xorg-configurations")
+
+(define merge-xorg-configurations
+  (@@ (gnu services xorg) merge-xorg-configurations))
+
+(define gdm-configuration-xorg
+  (@@ (gnu services xorg) gdm-configuration-xorg))
+
+;; keyboard-layout tests.
+
+(define %config-xorg-keyboard-layout-1
+  (xorg-configuration
+    (keyboard-layout (keyboard-layout "us" #:options '("ctrl:nocaps")))))
+
+(define %config-xorg-keyboard-layout-2
+  (xorg-configuration
+    (keyboard-layout (keyboard-layout "us" #:options '("ctrl:esc")))))
+
+;; Later keyboard layouts replace earlier defaults
+(test-equal
+    (keyboard-layout "us" #:options '("ctrl:nocaps"))
+  (xorg-configuration-keyboard-layout
+   (merge-xorg-configurations
+    (list %config-empty %config-xorg-keyboard-layout-1))))
+
+;; Later keyboard layouts replace earlier customizations.
+(test-equal
+    (keyboard-layout "us" #:options '("ctrl:esc"))
+  (xorg-configuration-keyboard-layout
+   (merge-xorg-configurations (list %config-empty
+                                    %config-xorg-keyboard-layout-1
+                                    %config-xorg-keyboard-layout-2))))
+
+;; server, server-arguments tests.
+
+(define %custom-server-1
+  (package
+    (inherit xorg-server)
+    (name "fake-xorg-server")))
+
+(define %custom-server-2
+  (package
+    (inherit xorg-server)
+    (name "another-fake-xorg-server")))
+
+(define %custom-server-1-arguments
+  (cons "-nosilk" %default-xorg-server-arguments))
+
+(define %custom-server-2-arguments
+  (cons* "-logverbose" "9" %default-xorg-server-arguments))
+
+(define %config-custom-server-1
+  (xorg-configuration
+    (server %custom-server-1)))
+
+(define %config-custom-server-2
+  (xorg-configuration
+    (server %custom-server-2)))
+
+(define %config-custom-server-1-and-arguments
+  (xorg-configuration
+    (inherit %config-custom-server-1)
+    (server-arguments %custom-server-1-arguments)))
+
+(define %config-custom-server-2-and-arguments
+  (xorg-configuration
+    (inherit %config-custom-server-2)
+    (server-arguments %custom-server-2-arguments)))
+
+;; Custom server is prioritized over earlier default.
+(test-equal
+    %custom-server-1
+  (xorg-configuration-server
+   (merge-xorg-configurations (list %config-empty
+                                    %config-custom-server-1))))
+
+;; Custom server preserves arguments.
+(test-equal
+    (list %custom-server-1 %custom-server-1-arguments)
+  (let ((cfg (merge-xorg-configurations
+              (list
+               %config-empty
+               %config-custom-server-1-and-arguments))))
+    (list (xorg-configuration-server cfg)
+          (xorg-configuration-server-arguments cfg))))
+
+;; Later custom arguments replace earlier.
+(test-equal
+    (list %custom-server-2 %custom-server-2-arguments)
+  (let ((cfg (merge-xorg-configurations
+              (list
+               %config-empty
+               %config-custom-server-1-and-arguments
+               %config-custom-server-2-and-arguments))))
+    (list (xorg-configuration-server cfg)
+          (xorg-configuration-server-arguments cfg))))
+
+;; Custom server is prioritized over later default.
+(test-equal
+    %custom-server-1
+  (xorg-configuration-server
+   (merge-xorg-configurations (list %config-custom-server-1
+                                    %config-empty))))
+
+;; Custom arguments are prioritized over earlier custom server.
+(test-equal
+    %custom-server-2-arguments
+  (xorg-configuration-server-arguments
+   (merge-xorg-configurations
+    (list
+     (xorg-configuration (server %custom-server-1))
+     (xorg-configuration (server-arguments %custom-server-2-arguments))))))
+
+;; Later custom servers are prioritized over earlier.
+(test-equal
+    %custom-server-2
+  (xorg-configuration-server
+   (merge-xorg-configurations (list %config-custom-server-1
+                                    %config-empty
+                                    %config-custom-server-2))))
+
+(test-equal
+    %custom-server-2
+  (xorg-configuration-server
+   (merge-xorg-configurations (list %config-empty
+                                    %config-custom-server-1
+                                    %config-custom-server-2))))
+
+(test-equal
+    %custom-server-1
+  (xorg-configuration-server
+   (merge-xorg-configurations (list %config-empty
+                                    %config-custom-server-1))))
+
+;; Make sure it works in the context of an operating-system.
+(test-equal
+    %custom-server-2
+  (let ((os (operating-system
+              (host-name "test")
+              (bootloader
+                (bootloader-configuration
+                  (bootloader grub-bootloader)
+                  (targets '("/dev/sdX"))))
+              (file-systems
+               (cons
+                (file-system
+                  (device (file-system-label "my-root"))
+                  (mount-point "/")
+                  (type "ext4"))
+                %base-file-systems))
+              (services
+               (cons*
+                (simple-service 'server-2 gdm-service-type
+                                %config-custom-server-2)
+                (simple-service 'server-1 gdm-service-type
+                                %config-custom-server-1)
+                (service gdm-service-type)
+                %base-services)))))
+    (xorg-configuration-server
+     (gdm-configuration-xorg
+      (service-value
+       (fold-services
+        (operating-system-services os)
+        #:target-type gdm-service-type))))))
+
+;; extra-config tests.
+
+;; Extra configurations append.
+(let ((snippet-one "# First")
+      (snippet-two "# Second"))
+  (test-equal
+      (list snippet-one snippet-two)
+    (xorg-configuration-extra-config
+     (merge-xorg-configurations
+      (list (xorg-configuration (extra-config (list snippet-one)))
+            (xorg-configuration (extra-config (list snippet-two))))))))
+
+;; drivers tests.
+
+(define %drivers-custom-1 '("done"))
+(define %drivers-custom-2 '("dtwo"))
+
+(test-equal
+    (append %drivers-custom-1 %drivers-custom-2)
+  (xorg-configuration-drivers
+   (merge-xorg-configurations
+    (list
+     (xorg-configuration (drivers %drivers-custom-1))
+     (xorg-configuration (drivers %drivers-custom-2))))))
+
+(test-end "merge-xorg-configurations")