| 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)))))) |