02/03: services: console-font: A single service handles all the VTs.

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository guix.

commit 4a84a48742ab9e15d7d527c3d965f907ec40672c
Author: Ludovic Courtès <address@hidden>
Date:   Mon Sep 19 23:36:17 2016 +0900

    services: console-font: A single service handles all the VTs.
    
    * gnu/services/base.scm (%default-console-font): New variable.
    (console-font-shepherd-services): New procedure.
    (console-font-service-type): Change to use 'service-type'.
    (console-font-service): Rewrite using 'simple-service'.
    (%base-services): Use a single CONSOLE-FONT-SERVICE-TYPE instance.
    * gnu/system/install.scm (installation-services): Likewise.
---
 gnu/services/base.scm  |   80 ++++++++++++++++++++++++++++--------------------
 gnu/system/install.scm |   10 +++---
 2 files changed, 51 insertions(+), 39 deletions(-)

diff --git a/gnu/services/base.scm b/gnu/services/base.scm
index 4c1c481..afbecdb 100644
--- a/gnu/services/base.scm
+++ b/gnu/services/base.scm
@@ -58,6 +58,8 @@
             session-environment-service-type
             host-name-service
             console-keymap-service
+            %default-console-font
+            console-font-service-type
             console-font-service
 
             udev-configuration
@@ -635,37 +637,51 @@ strings or string-valued gexps."
   "Return a service to load console keymaps from @var{files}."
   (service console-keymap-service-type files))
 
-(define console-font-service-type
-  (shepherd-service-type
-   'console-font
-   (match-lambda
-     ((tty font)
-      (let ((device (string-append "/dev/" tty)))
-        (shepherd-service
-         (documentation "Load a Unicode console font.")
-         (provision (list (symbol-append 'console-font-
-                                         (string->symbol tty))))
-
-         ;; Start after mingetty has been started on TTY, otherwise the 
settings
-         ;; are ignored.
-         (requirement (list (symbol-append 'term-
-                                           (string->symbol tty))))
+(define %default-console-font
+  ;; Note: 'LatGrkCyr-8x16' has the advantage of providing three common
+  ;; scripts as well as glyphs for em dash, quotation marks, and other Unicode
+  ;; codepoints notably found in the UTF-8 manual.
+  "LatGrkCyr-8x16")
+
+(define (console-font-shepherd-services tty+font)
+  "Return a list of Shepherd services for each pair in TTY+FONT."
+  (map (match-lambda
+         ((tty . font)
+          (let ((device (string-append "/dev/" tty)))
+            (shepherd-service
+             (documentation "Load a Unicode console font.")
+             (provision (list (symbol-append 'console-font-
+                                             (string->symbol tty))))
+
+             ;; Start after mingetty has been started on TTY, otherwise the 
settings
+             ;; are ignored.
+             (requirement (list (symbol-append 'term-
+                                               (string->symbol tty))))
+
+             (start #~(lambda _
+                        (and #$(unicode-start device)
+                             (zero?
+                              (system* (string-append #$kbd "/bin/setfont")
+                                       "-C" #$device #$font)))))
+             (stop #~(const #t))
+             (respawn? #f)))))
+       tty+font))
 
-         (start #~(lambda _
-                    (and #$(unicode-start device)
-                         (zero?
-                          (system* (string-append #$kbd "/bin/setfont")
-                                   "-C" #$device #$font)))))
-         (stop #~(const #t))
-         (respawn? #f)))))))
+(define console-font-service-type
+  (service-type (name 'console-fonts)
+                (extensions
+                 (list (service-extension shepherd-root-service-type
+                                          console-font-shepherd-services)))
+                (compose concatenate)
+                (extend append)))
 
 (define* (console-font-service tty #:optional (font "LatGrkCyr-8x16"))
-  "Return a service that sets up Unicode support in @var{tty} and loads
+  "This procedure is deprecated in favor of @code{console-font-service-type}.
+
+Return a service that sets up Unicode support in @var{tty} and loads
 @var{font} for that tty (fonts are per virtual console in Linux.)"
-  ;; Note: 'LatGrkCyr-8x16' has the advantage of providing three common
-  ;; scripts as well as glyphs for em dash, quotation marks, and other Unicode
-  ;; codepoints notably found in the UTF-8 manual.
-  (service console-font-service-type (list tty font)))
+  (simple-service (symbol-append 'console-font- (string->symbol tty))
+                  console-font-service-type `((,tty . ,font))))
 
 (define %default-motd
   (plain-file "motd" "This is the GNU operating system, welcome!\n\n"))
@@ -1497,12 +1513,10 @@ This service is not part of @var{%base-services}."
   ;; Convenience variable holding the basic services.
   (list (login-service)
 
-        (console-font-service "tty1")
-        (console-font-service "tty2")
-        (console-font-service "tty3")
-        (console-font-service "tty4")
-        (console-font-service "tty5")
-        (console-font-service "tty6")
+        (service console-font-service-type
+                 (map (lambda (tty)
+                        (cons tty %default-console-font))
+                      '("tty1" "tty2" "tty3" "tty4" "tty5" "tty6")))
 
         (mingetty-service (mingetty-configuration
                            (tty "tty1")))
diff --git a/gnu/system/install.scm b/gnu/system/install.scm
index b28925f..dfa003f 100644
--- a/gnu/system/install.scm
+++ b/gnu/system/install.scm
@@ -313,12 +313,10 @@ You have been warned.  Thanks for being so brave.
           (cow-store-service)
 
           ;; Install Unicode support and a suitable font.
-          (console-font-service "tty1")
-          (console-font-service "tty2")
-          (console-font-service "tty3")
-          (console-font-service "tty4")
-          (console-font-service "tty5")
-          (console-font-service "tty6")
+          (service console-font-service-type
+                   (map (lambda (tty)
+                          (cons tty %default-console-font))
+                        '("tty1" "tty2" "tty3" "tty4" "tty5" "tty6")))
 
           ;; To facilitate copy/paste.
           (gpm-service)