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
|
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2018 Mathieu Othacehe <m.othacehe@gmail.com>
;;;
;;; 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 keymap)
#:use-module (guix records)
#:use-module (sxml match)
#:use-module (sxml simple)
#:use-module (ice-9 binary-ports)
#:use-module (ice-9 ftw)
#:use-module (ice-9 match)
#:use-module (ice-9 regex)
#:export (<x11-keymap-model>
x11-keymap-model
make-x11-keymap-model
x11-keymap-model?
x11-keymap-model-name
x11-keymap-model-description
<x11-keymap-layout>
x11-keymap-layout
make-x11-keymap-layout
x11-keymap-layout?
x11-keymap-layout-name
x11-keymap-layout-description
x11-keymap-layout-variants
<x11-keymap-variant>
x11-keymap-variant
make-x11-keymap-variant
x11-keymap-variant?
x11-keymap-variant-name
x11-keymap-variant-description
xkb-rules->models+layouts
kmscon-update-keymap))
(define-record-type* <x11-keymap-model>
x11-keymap-model make-x11-keymap-model
x11-keymap-model?
(name x11-keymap-model-name) ;string
(description x11-keymap-model-description)) ;string
(define-record-type* <x11-keymap-layout>
x11-keymap-layout make-x11-keymap-layout
x11-keymap-layout?
(name x11-keymap-layout-name) ;string
(description x11-keymap-layout-description) ;string
(variants x11-keymap-layout-variants)) ;list of <x11-keymap-variant>
(define-record-type* <x11-keymap-variant>
x11-keymap-variant make-x11-keymap-variant
x11-keymap-variant?
(name x11-keymap-variant-name) ;string
(description x11-keymap-variant-description)) ;string
(define (xkb-rules->models+layouts file)
"Parse FILE and return two values, the list of supported X11-KEYMAP-MODEL
and X11-KEYMAP-LAYOUT records. FILE is an XML file from the X Keyboard
Configuration Database, describing possible XKB configurations."
(define (model m)
(sxml-match m
[(model
(configItem
(name ,name)
(description ,description)
. ,rest))
(x11-keymap-model
(name name)
(description description))]))
(define (variant v)
(sxml-match v
[(variant
;; According to xbd-rules DTD, the definition of a
;; configItem is: <!ELEMENT configItem
;; (name,shortDescription*,description*,vendor?,
;; countryList?,languageList?,hwList?)>
;;
;; shortDescription and description are optional elements
;; but sxml-match does not support default values for
;; elements (only attributes). So to avoid writing as many
;; patterns as existing possibilities, gather all the
;; remaining elements but name in REST-VARIANT.
(configItem
(name ,name)
. ,rest-variant))
(x11-keymap-variant
(name name)
(description (car
(assoc-ref rest-variant 'description))))]))
(define (layout l)
(sxml-match l
[(layout
(configItem
(name ,name)
. ,rest-layout)
(variantList ,[variant -> v] ...))
(x11-keymap-layout
(name name)
(description (car
(assoc-ref rest-layout 'description)))
(variants (list v ...)))]
[(layout
(configItem
(name ,name)
. ,rest-layout))
(x11-keymap-layout
(name name)
(description (car
(assoc-ref rest-layout 'description)))
(variants '()))]))
(let ((sxml (call-with-input-file file
(lambda (port)
(xml->sxml port #:trim-whitespace? #t)))))
(match
(sxml-match sxml
[(*TOP*
,pi
(xkbConfigRegistry
(@ . ,ignored)
(modelList ,[model -> m] ...)
(layoutList ,[layout -> l] ...)
. ,rest))
(list
(list m ...)
(list l ...))])
((models layouts)
(values models layouts)))))
(define (kmscon-update-keymap model layout variant)
(let ((keymap-file (getenv "KEYMAP_UPDATE")))
(unless (and keymap-file
(file-exists? keymap-file))
(error "Unable to locate keymap update file"))
(call-with-output-file keymap-file
(lambda (port)
(format port model)
(put-u8 port 0)
(format port layout)
(put-u8 port 0)
(format port variant)
(put-u8 port 0)))))
|
