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-synopsis
  40             x11-keymap-layout-description
  41             x11-keymap-layout-variants
  42
  43             <x11-keymap-variant>
  44             x11-keymap-variant
  45             make-x11-keymap-variant
  46             x11-keymap-variant?
  47             x11-keymap-variant-name
  48             x11-keymap-variant-description
  49
  50             default-keyboard-model
  51             xkb-rules->models+layouts
  52             kmscon-update-keymap))
  53
  54 (define-record-type* <x11-keymap-model>
  55   x11-keymap-model make-x11-keymap-model
  56   x11-keymap-model?
  57   (name            x11-keymap-model-name) ;string
  58   (description     x11-keymap-model-description)) ;string
  59
  60 (define-record-type* <x11-keymap-layout>
  61   x11-keymap-layout make-x11-keymap-layout
  62   x11-keymap-layout?
  63   (name            x11-keymap-layout-name) ;string
  64   (synopsis        x11-keymap-layout-synopsis)    ;string (e.g., "en")
  65   (description     x11-keymap-layout-description) ;string (a whole phrase)
  66   (variants        x11-keymap-layout-variants)) ;list of <x11-keymap-variant>
  67
  68 (define-record-type* <x11-keymap-variant>
  69   x11-keymap-variant make-x11-keymap-variant
  70   x11-keymap-variant?
  71   (name            x11-keymap-variant-name) ;string
  72   (description     x11-keymap-variant-description)) ;string
  73
  74 ;; Assume all modern keyboards have this model.
  75 (define default-keyboard-model (make-parameter "pc105"))
  76
  77 (define (xkb-rules->models+layouts file)
  78   "Parse FILE and return two values, the list of supported X11-KEYMAP-MODEL
  79 and X11-KEYMAP-LAYOUT records. FILE is an XML file from the X Keyboard
  80 Configuration Database, describing possible XKB configurations."
  81   (define (model m)
  82     (sxml-match m
  83                 [(model
  84                   (configItem
  85                    (name ,name)
  86                    (description ,description)
  87                    . ,rest))
  88                  (x11-keymap-model
  89                   (name name)
  90                   (description description))]))
  91
  92   (define (variant v)
  93     (sxml-match v
  94                 [(variant
  95                   ;; According to xbd-rules DTD, the definition of a
  96                   ;; configItem is: <!ELEMENT configItem
  97                   ;; (name,shortDescription*,description*,vendor?,
  98                   ;; countryList?,languageList?,hwList?)>
  99                   ;;
 100                   ;; shortDescription and description are optional elements
 101                   ;; but sxml-match does not support default values for
 102                   ;; elements (only attributes). So to avoid writing as many
 103                   ;; patterns as existing possibilities, gather all the
 104                   ;; remaining elements but name in REST-VARIANT.
 105                   (configItem
 106                    (name ,name)
 107                    . ,rest-variant))
 108                  (x11-keymap-variant
 109                   (name name)
 110                   (description (car
 111                                 (assoc-ref rest-variant 'description))))]))
 112
 113   (define (layout l)
 114     (sxml-match l
 115                 [(layout
 116                   (configItem
 117                    (name ,name)
 118                    . ,rest-layout)
 119                   (variantList ,[variant -> v] ...))
 120                  (x11-keymap-layout
 121                   (name name)
 122                   (synopsis (car
 123                              (assoc-ref rest-layout 'shortDescription)))
 124                   (description (car
 125                                 (assoc-ref rest-layout 'description)))
 126                   (variants (list v ...)))]
 127                 [(layout
 128                   (configItem
 129                    (name ,name)
 130                    . ,rest-layout))
 131                  (x11-keymap-layout
 132                   (name name)
 133                   (synopsis (car
 134                              (assoc-ref rest-layout 'shortDescription)))
 135                   (description (car
 136                                 (assoc-ref rest-layout 'description)))
 137                   (variants '()))]))
 138
 139   (let ((sxml (call-with-input-file file
 140                 (lambda (port)
 141                   (xml->sxml port #:trim-whitespace? #t)))))
 142     (match
 143         (sxml-match sxml
 144                     [(*TOP*
 145                       ,pi
 146                       (xkbConfigRegistry
 147                        (@ . ,ignored)
 148                        (modelList ,[model -> m] ...)
 149                        (layoutList ,[layout -> l] ...)
 150                        . ,rest))
 151                      (list
 152                       (list m ...)
 153                       (list l ...))])
 154       ((models layouts)
 155        (values models layouts)))))
 156
 157 (define (kmscon-update-keymap model layout variant)
 158   "Update kmscon keymap with the provided MODEL, LAYOUT and VARIANT."
 159   (and=>
 160    (getenv "KEYMAP_UPDATE")
 161    (lambda (keymap-file)
 162      (unless (file-exists? keymap-file)
 163        (error "Unable to locate keymap update file"))
 164
 165      ;; See file gnu/packages/patches/kmscon-runtime-keymap-switch.patch.
 166      ;; This dirty hack makes possible to update kmscon keymap at runtime by
 167      ;; writing an X11 keyboard model, layout and variant to a named pipe
 168      ;; referred by KEYMAP_UPDATE environment variable.
 169      (call-with-output-file keymap-file
 170        (lambda (port)
 171          (format port model)
 172          (put-u8 port 0)
 173
 174          (format port layout)
 175          (put-u8 port 0)
 176
 177          (format port variant)
 178          (put-u8 port 0))))))