gnu/installer/keymap.scm

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