(dynamic-call "scm_init_xkb"
	      (dynamic-link "libguile-xkb.so"))
(use-modules (srfi srfi-1))

(define data (xkb-get-all))

(define (language options)
  (let ((langlist (cond-plistq 'language options)))
    (reverse (fold (lambda(x y)
                     (if (> (string-length x) 2)
                         (cons* x (substring x 0 2) y)
                         (cons x y)))
                   '()
                   langlist))))

(define (get-description lst langlist)
  (cdr (assq (find (lambda(x)
             		(assq x lst))
                   (map sure-symbol (append langlist '(en))))
             lst)))
  
(define (out-list lst args)
  (let ((lang (language args)))
    (if lst
        (map (lambda (x) (list (car x) 'description
                               (get-description (cadr x) lang)))
             lst)
        '())))

(define (get-generic obj args)
    (out-list (cond-cdr (assq obj data)) args))

(define (get-sub-generic name obj args)
  (let ((layouts (cond-cdr (assq obj data))))
    (out-list (and (pair? layouts)
                   (cond-cdr
                    (cond-cadr
                     (cond-cdr
                      (find (lambda (x) (string=? (car x) name))
                            layouts)))))
              args)))

(define (quoted y)
  (string-append
    (string #\")
    y
    (string #\")))

(define (try-append str val)
  (or (and val
           (string-append str (quoted val)))
      ""))

(object
 #f
 ((list self objects options)
  (cond
   ((string=? (car objects) "models") (get-generic 'models options))
   ((string=? (car objects) "option_groups")
    (if (= (length objects) 1)
	(get-generic 'option_groups options)
        (get-sub-generic (cadr objects) 'option_groups options)))
   ((string=? (car objects) "layouts")
    (if (= (length objects) 1)
        (get-generic 'layouts options)
        (get-sub-generic (cadr objects) 'layouts options)))))
 ((read self objects options)
  (if (and (pair? objects) (string=? "current" (car objects)))
      (xkb-get-current)
      '()))
 ((write self objects options)
  (cond
   ((and (pair? objects)( string=? (car objects) "current"))
    (xkb-write-current
     (cond-plistq 'layout options)
     (cond-plistq 'model options)
     (cond-plistq 'options options)
     (cond-plistq 'variant options))
    '())
   ((and (pair? objects) (string=? (car objects) "reload"))
    (let* ((current (xkb-get-current))
           (options (cond-plistq 'options current))
           (variant (cond-plistq 'variant current))
           (model (cond-plistq 'model current))
           (layout (cond-plistq 'layout current)))
      (system (string-append "setxkbmap"
                             (try-append " -option -option " options)
                             (try-append " -model " model)
                             (try-append " -variant " variant)
                             (try-append " -layout " layout))))
    '())
   (else '(error "write action is unsupported for such object")))))
