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