04/14: Add (gnu system keyboard).

[guix-commits]

civodul pushed a commit to branch master
in repository guix.

commit db1e2522f6222594fc507ce7a7ba7b1c0ac5037d
Author: Ludovic Courtès <address@hidden>
Date:   Tue Mar 19 21:32:13 2019 +0100

    Add (gnu system keyboard).
    
    * gnu/system/keyboard.scm: New file.
    * gnu/local.mk (GNU_SYSTEM_MODULES): Add it.
    * gnu.scm (%public-modules): Add it.
---
 gnu.scm                 |  3 +-
 gnu/local.mk            |  1 +
 gnu/system/keyboard.scm | 98 +++++++++++++++++++++++++++++++++++++++++++++++++
 3 files changed, 101 insertions(+), 1 deletion(-)

diff --git a/gnu.scm b/gnu.scm
index 3e7e7c0..2c29b6d 100644
--- a/gnu.scm
+++ b/gnu.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2014, 2015, 2016, 2017 Ludovic Courtès <address@hidden>
+;;; Copyright © 2014, 2015, 2016, 2017, 2019 Ludovic Courtès <address@hidden>
 ;;; Copyright © 2015 Joshua S. Grant <address@hidden>
 ;;; Copyright © 2017 Mathieu Othacehe <address@hidden>
 ;;;
@@ -45,6 +45,7 @@
         (gnu system file-systems)
         (gnu bootloader)
         (gnu bootloader grub)
+        (gnu system keyboard)
         (gnu system pam)
         (gnu system shadow)                       ; 'user-account'
         (gnu system linux-initrd)
diff --git a/gnu/local.mk b/gnu/local.mk
index f957b8a..079b42c 100644
--- a/gnu/local.mk
+++ b/gnu/local.mk
@@ -538,6 +538,7 @@ GNU_SYSTEM_MODULES =                                \
   %D%/system/accounts.scm                      \
   %D%/system/file-systems.scm                  \
   %D%/system/install.scm                       \
+  %D%/system/keyboard.scm                      \
   %D%/system/linux-container.scm               \
   %D%/system/linux-initrd.scm                  \
   %D%/system/locale.scm                                \
diff --git a/gnu/system/keyboard.scm b/gnu/system/keyboard.scm
new file mode 100644
index 0000000..cd3ab37
--- /dev/null
+++ b/gnu/system/keyboard.scm
@@ -0,0 +1,98 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2019 Ludovic Courtès <address@hidden>
+;;;
+;;; 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 (gnu system keyboard)
+  #:use-module (guix gexp)
+  #:use-module ((gnu packages xorg)
+                #:select (xkeyboard-config console-setup))
+  #:use-module (srfi srfi-9 gnu)
+  #:use-module (ice-9 match)
+  #:export (keyboard-layout?
+            keyboard-layout
+            keyboard-layout-name
+            keyboard-layout-variant
+            keyboard-layout-model
+            keyboard-layout-options
+
+            keyboard-layout->console-keymap))
+
+;;; Commentary:
+;;;
+;;; This module provides a data structure to represent keyboard layouts
+;;; according to the XKB naming and classification (see the 'xkeyboard-config'
+;;; package).
+;;;
+;;; Code:
+
+(define-immutable-record-type <keyboard-layout>
+  (%keyboard-layout name variant model options)
+  keyboard-layout?
+  (name      keyboard-layout-name)                ;string
+  (variant   keyboard-layout-variant)             ;#f | string
+  (model     keyboard-layout-model)               ;#f | string
+  (options   keyboard-layout-options))            ;list of strings
+
+(define* (keyboard-layout name #:optional variant
+                          #:key model (options '()))
+  "Return a new keyboard layout with the given NAME and VARIANT.
+
+NAME must be a string such as \"fr\"; VARIANT must be a string such as
+\"bepo\" or \"nodeadkeys\".  See the 'xkeyboard-config' package for valid
+options."
+  (%keyboard-layout name variant model options))
+
+(define* (keyboard-layout->console-keymap layout
+                                          #:key
+                                          (xkeyboard-config xkeyboard-config))
+  "Return a Linux console keymap file for LAYOUT, a <keyboard-layout> record.
+Layout information is taken from the XKEYBOARD-CONFIG package."
+  (define build
+    (with-imported-modules '((guix build utils))
+      #~(begin
+          (use-modules (guix build utils)
+                       (ice-9 popen)
+                       (ice-9 match))
+
+          (define pipe
+            (open-pipe* OPEN_READ
+                        #+(file-append console-setup "/bin/ckbcomp")
+                        (string-append "-I"
+                                       #+(file-append xkeyboard-config
+                                                      "/share/X11/xkb"))
+                        "-rules" "base"
+                        #$@(match (keyboard-layout-model layout)
+                             (#f      '())
+                             (model   `("-model" ,model)))
+                        #$(keyboard-layout-name layout)
+                        #$(or (keyboard-layout-variant layout)
+                              "")
+                        #$(string-join (keyboard-layout-options layout) ",")))
+
+          (call-with-output-file #$output
+            (lambda (output)
+              (dump-port pipe output)))
+
+          ;; Note: ckbcomp errors out when the layout name is unknown, but
+          ;; merely emits a warning when the variant is unknown.
+          (unless (zero? (close-pipe pipe))
+            (error "failed to create console keymap for keyboard layout"
+                   #$(keyboard-layout-name layout))))))
+
+  (computed-file (string-append "console-keymap."
+                                (keyboard-layout-name layout))
+                 build))