aboutsummaryrefslogtreecommitdiff
path: root/gnu/installer/keymap.scm
blob: d9f8656855d442fbbd56d504ee07f54f4dbe33c2 (plain)
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
;;; 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

            default-keyboard-model
            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

;; Assume all modern keyboards have this model.
(define default-keyboard-model (make-parameter "pc105"))

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