You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.

182 lines
6.7 KiB

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