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.
 
 
 
 
 
 

163 lines
5.8 KiB

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