;; dbus.ffi				-*- Scheme -*-

;; Copyright (C) 2018 Matthew R. Wette
;;
;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
;; License as published by the Free Software Foundation; either
;; version 3 of the License, or (at your option) any later version.
;;
;; This library is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;; Lesser General Public License for more details.
;;
;; You should have received a copy of the GNU Lesser General Public License
;; along with this library; if not, see <http://www.gnu.org/licenses/>

;; See
;;   https://dbus.freedesktop.org/doc/api/html/modules.html
;;   https://dbus.freedesktop.org/doc/api/html/group__DBus.html
;;   bus=> https://dbus.freedesktop.org/doc/api/html/group__DBusBus.html

(define-ffi-module (ffi dbus)
  #:pkg-config "dbus-1"
  #:include '("dbus/dbus.h")
  #:inc-filter (lambda (file path) (string-contains path "dbus/" 0))
  )

(define-public dbus-symval ffi-dbus-symbol-val)

;; (DBUS 'SERVICE_BUS) => "org.freedesktop.DBus"
(define-public DBUS
  (let* ((cnvt (lambda (pair seed)
		 (let* ((k (car pair)) (v (cdr pair)) (n (symbol->string k)))
		   (if (string-prefix? "DBUS_" n)
		       (acons (string->symbol (substring n 5)) v seed)
		       seed))))
	 (symtab (let iter ((o '()) (i ffi-dbus-symbol-tab))
		   (if (null? i) o (iter (cnvt (car i) o) (cdr i))))))
    (lambda (key) (assq-ref symtab key))))

;; dbus_message_append_vals with extra help
(define dbus_message_append_args/xh
  (let ((t_INVALID (dbus-symval 'DBUS_TYPE_INVALID))
	(t_BYTE (dbus-symval 'DBUS_TYPE_BYTE))
	(t_BOOLEAN (dbus-symval 'DBUS_TYPE_BOOLEAN))
	(t_INT16 (dbus-symval 'DBUS_TYPE_INT16))
	(t_UINT16 (dbus-symval 'DBUS_TYPE_UINT16))
	(t_INT32 (dbus-symval 'DBUS_TYPE_INT32))
	(t_UINT32 (dbus-symval 'DBUS_TYPE_UINT32))
	(t_INT64 (dbus-symval 'DBUS_TYPE_INT64))
	(t_UINT64 (dbus-symval 'DBUS_TYPE_UINT64))
	(t_DOUBLE (dbus-symval 'DBUS_TYPE_DOUBLE))
	(t_STRING (dbus-symval 'DBUS_TYPE_STRING))
	(t_OBJECT_PATH (dbus-symval 'DBUS_TYPE_OBJECT_PATH))
	(t_SIGNATURE (dbus-symval 'DBUS_TYPE_SIGNATURE))
	(t_UNIX_FD (dbus-symval 'DBUS_TYPE_UNIX_FD))
	(t_ARRAY (dbus-symval 'DBUS_TYPE_ARRAY))
	(t_VARIANT (dbus-symval 'DBUS_TYPE_VARIANT))
	(t_STRUCT (dbus-symval 'DBUS_TYPE_STRUCT))
	(t_DICT_ENTRY (dbus-symval 'DBUS_TYPE_DICT_ENTRY)))
    (define (dbus->ffi-type dbus-type)
      (case dbus-type
	((t_INVALID DBUS_TYPE_INVALID) 'INVALID)
	((t_BYTE DBUS_TYPE_BYTE) ffi:uint8)
	((t_BOOLEAN DBUS_TYPE_BOOLEAN) ffi:unsigned-int)
	((t_INT16 DBUS_TYPE_INT16) ffi:int16)
	((t_UINT16 DBUS_TYPE_UINT16) ffi:uint16)
	((t_INT32 DBUS_TYPE_INT32) ffi:int32)
	((t_UINT32 DBUS_TYPE_UINT32) ffi:uint32)
	((t_INT64 DBUS_TYPE_INT64) ffi:int64)
	((t_UINT64 DBUS_TYPE_UINT64) ffi:uint64)
	((t_DOUBLE DBUS_TYPE_DOUBLE) ffi:double)
	((t_STRING DBUS_TYPE_STRING) '*)
	((t_ARRAY DBUS_TYPE_ARRAY) '*)
	((t_VARIANT DBUS_TYPE_VARIANT) '*)
	((t_STRUCT DBUS_TYPE_STRUCT) '*)
	((t_DICT_ENTRY DBUS_TYPE_DICT_ENTRY) '*)
	(else (error "yuck"))))
    (lambda (message . args)
      (apply
       dbus_message_append_args message
       (let loop ((args args))
	(cond
	 ((null? args) #t)
	 ((eq? (dbus->ffi-type (car args)) 'INVALID)
	  (cons 'int t_INVALID))
	 ((null? (cdr args)) (error "bad call"))
	 (else (let* ((dbus-type (car args))
		      (ffi-type (dbus->ffi-type dbus-type))
		      (arg-value (cadr args)))
		 (cons* (cons ffi:int (unwrap-enum dbus-type))
			(cons ffi-type arg-value)
			(loop (cddr args)))))))))))

;; --- last line ---
