gnu/installer/newt/keymap.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2018 Mathieu Othacehe <m.othacehe@gmail.com>
   3 ;;; Copyright © 2019 Ludovic Courtès <ludo@gnu.org>
   4 ;;;
   5 ;;; This file is part of GNU Guix.
   6 ;;;
   7 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   8 ;;; under the terms of the GNU General Public License as published by
   9 ;;; the Free Software Foundation; either version 3 of the License, or (at
  10 ;;; your option) any later version.
  11 ;;;
  12 ;;; GNU Guix is distributed in the hope that it will be useful, but
  13 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  14 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 ;;; GNU General Public License for more details.
  16 ;;;
  17 ;;; You should have received a copy of the GNU General Public License
  18 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  19
  20 (define-module (gnu installer newt keymap)
  21   #:use-module (gnu installer keymap)
  22   #:use-module (gnu installer steps)
  23   #:use-module (gnu installer newt page)
  24   #:use-module (guix i18n)
  25   #:use-module (guix records)
  26   #:use-module (newt)
  27   #:use-module (srfi srfi-1)
  28   #:use-module (srfi srfi-26)
  29   #:use-module (srfi srfi-34)
  30   #:use-module (srfi srfi-35)
  31   #:use-module (ice-9 i18n)
  32   #:use-module (ice-9 match)
  33   #:export (run-keymap-page
  34             keyboard-layout->configuration))
  35
  36 (define (run-layout-page layouts layout->text)
  37   (let ((title (G_ "Layout")))
  38     (run-listbox-selection-page
  39      #:title title
  40      #:info-text (G_ "Please choose your keyboard layout.")
  41      #:listbox-items layouts
  42      #:listbox-item->text layout->text
  43      #:sort-listbox-items? #f
  44      #:button-text (G_ "Exit")
  45      #:button-callback-procedure
  46      (lambda _
  47        (raise
  48         (condition
  49          (&installer-step-abort)))))))
  50
  51 (define (run-variant-page variants variant->text)
  52   (let ((title (G_ "Variant")))
  53     (run-listbox-selection-page
  54      #:title title
  55      #:info-text (G_ "Please choose a variant for your keyboard layout.")
  56      #:listbox-items variants
  57      #:listbox-item->text variant->text
  58      #:sort-listbox-items? #f
  59      #:button-text (G_ "Back")
  60      #:button-callback-procedure
  61      (lambda _
  62        (raise
  63         (condition
  64          (&installer-step-abort)))))))
  65
  66 (define (sort-layouts layouts)
  67   "Sort LAYOUTS list by putting the US layout ahead and return it."
  68   (define (layout<? layout1 layout2)
  69     (let ((text1 (x11-keymap-layout-description layout1))
  70           (text2 (x11-keymap-layout-description layout2)))
  71       ;; XXX: We're calling 'gettext' more than once per item.
  72       (string-locale<? (gettext text1 "xkeyboard-config")
  73                        (gettext text2 "xkeyboard-config"))))
  74
  75   (define preferred
  76     ;; Two-letter language tag for the preferred keyboard layout.
  77     (or (getenv "LANGUAGE") "us"))
  78
  79   (call-with-values
  80       (lambda ()
  81         (partition
  82          (lambda (layout)
  83            ;; The 'synopsis' field is usually a language code (e.g., "en")
  84            ;; while the 'name' field is a country code (e.g., "us").
  85            (or (string=? (x11-keymap-layout-name layout) preferred)
  86                (string=? (x11-keymap-layout-synopsis layout) preferred)))
  87          layouts))
  88     (lambda (main others)
  89       (append (sort main layout<?)
  90               (sort others layout<?)))))
  91
  92 (define (sort-variants variants)
  93   "Sort VARIANTS list by putting the international variant ahead and return it."
  94   (call-with-values
  95       (lambda ()
  96         (partition
  97          (lambda (variant)
  98            (let ((name (x11-keymap-variant-name variant)))
  99              (string=? name "altgr-intl")))
 100          variants))
 101     (cut append <> <>)))
 102
 103 (define* (run-keymap-page layouts)
 104   "Run a page asking the user to select a keyboard layout and variant. LAYOUTS
 105 is a list of supported X11-KEYMAP-LAYOUT. Return a list of two elements, the
 106 names of the selected keyboard layout and variant."
 107   (define keymap-steps
 108     (list
 109      (installer-step
 110       (id 'layout)
 111       (compute
 112        (lambda _
 113          (run-layout-page
 114           (sort-layouts layouts)
 115           (lambda (layout)
 116             (gettext (x11-keymap-layout-description layout)
 117                      "xkeyboard-config"))))))
 118      ;; Propose the user to select a variant among those supported by the
 119      ;; previously selected layout.
 120      (installer-step
 121       (id 'variant)
 122       (compute
 123        (lambda (result _)
 124          (let* ((layout (result-step result 'layout))
 125                 (variants (x11-keymap-layout-variants layout)))
 126            ;; Return #f if the layout does not have any variant.
 127            (and (not (null? variants))
 128                 (run-variant-page
 129                  (sort-variants variants)
 130                  (lambda (variant)
 131                    (gettext (x11-keymap-variant-description variant)
 132                             "xkeyboard-config"))))))))))
 133
 134   (define (format-result result)
 135     (let ((layout (x11-keymap-layout-name
 136                    (result-step result 'layout)))
 137           (variant (and=> (result-step result 'variant)
 138                           (lambda (variant)
 139                             (gettext (x11-keymap-variant-name variant)
 140                                      "xkeyboard-config")))))
 141       (list layout (or variant ""))))
 142   (format-result
 143    (run-installer-steps #:steps keymap-steps)))
 144
 145 (define (keyboard-layout->configuration keymap)
 146   "Return the operating system configuration snippet to install KEYMAP."
 147   (match keymap
 148     ((name "")
 149      `((keyboard-layout (keyboard-layout ,name))))
 150     ((name variant)
 151      `((keyboard-layout (keyboard-layout ,name ,variant))))))