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

(define data (xkb-get-all))

(define (out-list lst)
  (if lst
      (map (lambda (x) (list (car x) 'description
			     (if (pair? (cdr x))
			       (cadr x)
			       (cdr x))))
	   lst)
      '()))

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

(define (get-sub-generic name obj)
  (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))))))))
(define (quoted y)
  (string-append
    (string #\")
    y
    (string #\")))


(lambda (objects action)
  (case action
    ((list) (cond
	      ((string=? (car objects) "models")
	       (lambda args (get-generic 'models)))
	      ((string=? (car objects) "option_groups")
	       (if (= (length objects) 1)
		 (lambda args (get-generic 'option_groups))
		 (lambda args (get-sub-generic (cadr objects) 'option_groups))))
	      ((string=? (car objects) "layouts")
	       (if (= (length objects) 1)
	         (lambda args (get-generic 'layouts))
		 (lambda args (get-sub-generic (cadr objects) 'layouts))))))
    ((read) (if (and (pair? objects)
		     (string=? "current" (car objects)))
	      (lambda args (xkb-get-current))))
    ((write) (if (pair? objects)
	       (cond
		 ((string=? (car objects) "current")
		  (lambda (args)
		    (xkb-write-current
		      (cond-cdr (assq 'layout args))
		      (cond-cdr (assq 'model args))
		      (cond-cdr (assq 'options args))
		      (cond-cdr (assq 'variant args)))
		    #f))
		 ((string=? (car objects) "reload")
		  (lambda args
		    (system (string-append "setxkbmap"
			    (command-fold
			      (lambda (x y init)
				(case x
				  ((options) (string-append init " -option -option "(quoted y)))
				  ((model) (string-append init " -model " (quoted y)))
				  ((variant) (string-append init " -variant " (quoted y)))
				  ((layout) (string-append init " -layout " (quoted y)))
				  (else init)))
			      ""
			      (cons 'head (xkb-get-current)))))
		    #f))
		  (else (error-mariner "write action is unsupported for such object")))
	       (error-mariner "invalid write action format")))
    (else (error-mariner "unsupported action for xkb backend"))))
