summaryrefslogtreecommitdiff
path: root/gnu/installer/keymap.scm
diff options
context:
space:
mode:
Diffstat (limited to 'gnu/installer/keymap.scm')
-rw-r--r--gnu/installer/keymap.scm162
1 files changed, 162 insertions, 0 deletions
diff --git a/gnu/installer/keymap.scm b/gnu/installer/keymap.scm
new file mode 100644
index 0000000000..78065aa6c6
--- /dev/null
+++ b/gnu/installer/keymap.scm
@@ -0,0 +1,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)))))