gnu/installer/keymap.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2018 Mathieu Othacehe <m.othacehe@gmail.com>
   3 ;;;
   4 ;;; This file is part of GNU Guix.
   5 ;;;
   6 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   7 ;;; under the terms of the GNU General Public License as published by
   8 ;;; the Free Software Foundation; either version 3 of the License, or (at
   9 ;;; your option) any later version.
  10 ;;;
  11 ;;; GNU Guix is distributed in the hope that it will be useful, but
  12 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 ;;; GNU General Public License for more details.
  15 ;;;
  16 ;;; You should have received a copy of the GNU General Public License
  17 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  18
  19 (define-module (gnu installer keymap)
  20   #:use-module (guix records)
  21   #:use-module (sxml match)
  22   #:use-module (sxml simple)
  23   #:use-module (ice-9 binary-ports)
  24   #:use-module (ice-9 ftw)
  25   #:use-module (ice-9 match)
  26   #:use-module (ice-9 regex)
  27   #:export (<x11-keymap-model>
  28             x11-keymap-model
  29             make-x11-keymap-model
  30             x11-keymap-model?
  31             x11-keymap-model-name
  32             x11-keymap-model-description
  33
  34             <x11-keymap-layout>
  35             x11-keymap-layout
  36             make-x11-keymap-layout
  37             x11-keymap-layout?
  38             x11-keymap-layout-name
  39             x11-keymap-layout-description
  40             x11-keymap-layout-variants
  41
  42             <x11-keymap-variant>
  43             x11-keymap-variant
  44             make-x11-keymap-variant
  45             x11-keymap-variant?
  46             x11-keymap-variant-name
  47             x11-keymap-variant-description
  48
  49             default-keyboard-model
  50             xkb-rules->models+layouts
  51             kmscon-update-keymap))
  52
  53 (define-record-type* <x11-keymap-model>
  54   x11-keymap-model make-x11-keymap-model
  55   x11-keymap-model?
  56   (name            x11-keymap-model-name) ;string
  57   (description     x11-keymap-model-description)) ;string
  58
  59 (define-record-type* <x11-keymap-layout>
  60   x11-keymap-layout make-x11-keymap-layout
  61   x11-keymap-layout?
  62   (name            x11-keymap-layout-name) ;string
  63   (description     x11-keymap-layout-description) ;string
  64   (variants        x11-keymap-layout-variants)) ;list of <x11-keymap-variant>
  65
  66 (define-record-type* <x11-keymap-variant>
  67   x11-keymap-variant make-x11-keymap-variant
  68   x11-keymap-variant?
  69   (name            x11-keymap-variant-name) ;string
  70   (description     x11-keymap-variant-description)) ;string
  71
  72 ;; Assume all modern keyboards have this model.
  73 (define default-keyboard-model (make-parameter "pc105"))
  74
  75 (define (xkb-rules->models+layouts file)
  76   "Parse FILE and return two values, the list of supported X11-KEYMAP-MODEL
  77 and X11-KEYMAP-LAYOUT records. FILE is an XML file from the X Keyboard
  78 Configuration Database, describing possible XKB configurations."
  79   (define (model m)
  80     (sxml-match m
  81                 [(model
  82                   (configItem
  83                    (name ,name)
  84                    (description ,description)
  85                    . ,rest))
  86                  (x11-keymap-model
  87                   (name name)
  88                   (description description))]))
  89
  90   (define (variant v)
  91     (sxml-match v
  92                 [(variant
  93                   ;; According to xbd-rules DTD, the definition of a
  94                   ;; configItem is: <!ELEMENT configItem
  95                   ;; (name,shortDescription*,description*,vendor?,
  96                   ;; countryList?,languageList?,hwList?)>
  97                   ;;
  98                   ;; shortDescription and description are optional elements
  99                   ;; but sxml-match does not support default values for
 100                   ;; elements (only attributes). So to avoid writing as many
 101                   ;; patterns as existing possibilities, gather all the
 102                   ;; remaining elements but name in REST-VARIANT.
 103                   (configItem
 104                    (name ,name)
 105                    . ,rest-variant))
 106                  (x11-keymap-variant
 107                   (name name)
 108                   (description (car
 109                                 (assoc-ref rest-variant 'description))))]))
 110
 111   (define (layout l)
 112     (sxml-match l
 113                 [(layout
 114                   (configItem
 115                    (name ,name)
 116                    . ,rest-layout)
 117                   (variantList ,[variant -> v] ...))
 118                  (x11-keymap-layout
 119                   (name name)
 120                   (description (car
 121                                 (assoc-ref rest-layout 'description)))
 122                   (variants (list v ...)))]
 123                 [(layout
 124                   (configItem
 125                    (name ,name)
 126                    . ,rest-layout))
 127                  (x11-keymap-layout
 128                   (name name)
 129                   (description (car
 130                                 (assoc-ref rest-layout 'description)))
 131                   (variants '()))]))
 132
 133   (let ((sxml (call-with-input-file file
 134                 (lambda (port)
 135                   (xml->sxml port #:trim-whitespace? #t)))))
 136     (match
 137         (sxml-match sxml
 138                     [(*TOP*
 139                       ,pi
 140                       (xkbConfigRegistry
 141                        (@ . ,ignored)
 142                        (modelList ,[model -> m] ...)
 143                        (layoutList ,[layout -> l] ...)
 144                        . ,rest))
 145                      (list
 146                       (list m ...)
 147                       (list l ...))])
 148       ((models layouts)
 149        (values models layouts)))))
 150
 151 (define (kmscon-update-keymap model layout variant)
 152   (let ((keymap-file (getenv "KEYMAP_UPDATE")))
 153     (unless (and keymap-file
 154                  (file-exists? keymap-file))
 155       (error "Unable to locate keymap update file"))
 156
 157     (call-with-output-file keymap-file
 158         (lambda (port)
 159           (format port model)
 160           (put-u8 port 0)
 161
 162           (format port layout)
 163           (put-u8 port 0)
 164
 165           (format port variant)
 166           (put-u8 port 0)))))