1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
|
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2018, 2020 Mathieu Othacehe <m.othacehe@gmail.com>
;;; Copyright © 2019 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2020 Florian Pelz <pelzflorian@pelzflorian.de>
;;;
;;; 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 installer newt keymap)
#:use-module (gnu installer keymap)
#:use-module (gnu installer steps)
#:use-module (gnu installer newt page)
#:use-module (guix i18n)
#:use-module (guix records)
#:use-module (newt)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
#:use-module (srfi srfi-34)
#:use-module (srfi srfi-35)
#:use-module (ice-9 i18n)
#:use-module (ice-9 match)
#:export (run-keymap-page
keyboard-layout->configuration))
(define (run-layout-page layouts layout->text context)
(let ((title (G_ "Layout")))
(run-listbox-selection-page
#:title title
#:info-text
(case context
((param) (G_ "Please choose your keyboard layout. \
It will only be used during the installation process. \
Non-Latin layouts can be toggled with Alt+Shift."))
(else (G_ "Please choose your keyboard layout. \
It will be used during the install process, and for the installed system. \
Non-Latin layouts can be toggled with Alt+Shift. You can switch to a \
different layout at any time from the parameters menu.")))
#:listbox-items layouts
#:listbox-item->text layout->text
#:sort-listbox-items? #f
#:button-text
(case context
((param) (G_ "Continue"))
(else (G_ "Exit")))
#:button-callback-procedure
(case context
((param) (const #t))
(else
(lambda _
(raise
(condition
(&installer-step-abort)))))))))
(define (run-variant-page variants variant->text)
(let ((title (G_ "Variant")))
(run-listbox-selection-page
#:title title
#:info-text (G_ "Please choose a variant for your keyboard layout.")
#:listbox-items variants
#:listbox-item->text variant->text
#:sort-listbox-items? #f
#:button-text (G_ "Back")
#:button-callback-procedure
(lambda _
(raise
(condition
(&installer-step-abort)))))))
(define (sort-layouts layouts)
"Sort LAYOUTS list by putting the US layout ahead and return it."
(define (layout<? layout1 layout2)
(let ((text1 (x11-keymap-layout-description layout1))
(text2 (x11-keymap-layout-description layout2)))
;; XXX: We're calling 'gettext' more than once per item.
(string-locale<? (gettext text1 "xkeyboard-config")
(gettext text2 "xkeyboard-config"))))
(define preferred
;; Two-letter language tag for the preferred keyboard layout.
(or (getenv "LANGUAGE") "us"))
(call-with-values
(lambda ()
(partition
(lambda (layout)
;; The 'synopsis' field is usually a language code (e.g., "en")
;; while the 'name' field is a country code (e.g., "us").
(or (string=? (x11-keymap-layout-name layout) preferred)
(string=? (x11-keymap-layout-synopsis layout) preferred)))
layouts))
(lambda (main others)
(append (sort main layout<?)
(sort others layout<?)))))
(define (add-empty-variant variants)
"Prepend #f to VARIANTS so the user has the option to select no variant.
The resulting layout may be different from all other variants (e.g. for
Azerbaijani)."
(cons #f variants))
(define (sort-variants variants)
"Sort VARIANTS list by putting the international variant ahead and return it."
(call-with-values
(lambda ()
(partition
(lambda (variant)
(and variant
(let ((name (x11-keymap-variant-name variant)))
(string=? name "altgr-intl"))))
variants))
(cut append <> <>)))
(define %non-latin-layouts
;; List of keyboard layouts marked as $nonlatin in xkeyboard-config.
;; See comments in xkeyboard-config file /share/X11/xkb/rules/base.
;; We ignore layouts that support Latin input: "kr"
'("am" "ara" "ben" "bd" "bg" "bt" "by" "cs" "deva" "ge" "gh"
"gr" "guj" "guru" "il" "in" "ir" "iku" "jp" "kan" "kh"
"la" "lao" "lk" "mk" "mm" "mn" "mv" "mal" "olck" "ori" "pk"
"ru" "scc" "sy" "syr" "tel" "th" "tj" "tam" "ua" "uz"
;; The list from xkeyboard-config is incomplete. Add more layouts when
;; noticed:
"et" "kz"))
(define %non-latin-variants
'("cyrillic"))
(define %latin-layout+variants
;; These layout+variant combinations are Latin after all.
'(("ir" "ku")))
(define (toggleable-latin-layout layout variant)
"If LAYOUT is a non-Latin layout, return a new combined layout,
a variant, and options that allow the user to switch between the
non-Latin and the Latin layout. Otherwise, return LAYOUT, VARIANT,
and #f."
(if (and (not (equal? variant "latin"))
(not (member (list layout variant) %latin-layout+variants))
(or (member layout %non-latin-layouts)
(member variant %non-latin-variants)))
(let ((latin-layout (if (equal? variant "azerty") "fr" "us")))
(list
(string-append layout "," latin-layout)
;; Comma to use variant only for non-Latin:
(and variant (string-append variant ","))
"grp:alt_shift_toggle"))
(list layout variant #f)))
(define* (run-keymap-page layouts #:key (context #f))
"Run a page asking the user to select a keyboard layout and variant. LAYOUTS
is a list of supported X11-KEYMAP-LAYOUT. For non-Latin keyboard layouts, a
second layout and toggle options will be added automatically. Return a list
of three elements, the names of the selected keyboard layout, variant and
options."
(define keymap-steps
(list
(installer-step
(id 'layout)
(compute
(lambda _
(run-layout-page
(sort-layouts layouts)
(lambda (layout)
(gettext (x11-keymap-layout-description layout)
"xkeyboard-config"))
context))))
;; Propose the user to select a variant among those supported by the
;; previously selected layout.
(installer-step
(id 'variant)
(compute
(lambda (result _)
(let* ((layout (result-step result 'layout))
(variants (x11-keymap-layout-variants layout)))
;; Return #f if the layout does not have any variant.
(and (not (null? variants))
(run-variant-page
(sort-variants (add-empty-variant variants))
(lambda (variant)
(if variant
(gettext (x11-keymap-variant-description variant)
"xkeyboard-config")
;; Text to opt for no variant at all:
(gettext (x11-keymap-layout-description layout)
"xkeyboard-config")))))))))))
(define (format-result result)
(let ((layout (x11-keymap-layout-name
(result-step result 'layout)))
(variant (and=> (result-step result 'variant)
(lambda (variant)
(gettext (x11-keymap-variant-name variant)
"xkeyboard-config")))))
(toggleable-latin-layout layout variant)))
(format-result
(run-installer-steps #:steps keymap-steps)))
(define (keyboard-layout->configuration keymap)
"Return the operating system configuration snippet to install KEYMAP."
(match keymap
((name #f "grp:alt_shift_toggle")
`((keyboard-layout (keyboard-layout ,name
#:options '("grp:alt_shift_toggle")))))
((name #f _)
`((keyboard-layout (keyboard-layout ,name))))
((name variant "grp:alt_shift_toggle")
`((keyboard-layout (keyboard-layout ,name ,variant
#:options '("grp:alt_shift_toggle")))))
((name variant _)
`((keyboard-layout (keyboard-layout ,name ,variant))))))
|
