;;; glib.sls --- Glossing for the GLib namespace.

;; Copyright (C) 2009-2011 Andreas Rottmann <a.rottmann@gmx.at>

;; Author: Andreas Rottmann <a.rottmann@gmx.at>

;; This file 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 program 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 program.  If not, see
;; <http://www.gnu.org/licenses/>.

;;; Commentary:

;;; Code:
#!r6rs

(library (sbank glib)
  (export send
          #!@(typelib-exports
              (prefix ("GLib" #f) g-)
              (name glib)
              (exclude "_.*"

                       ".*_FORMAT"
                       "SYSDEF_.*"
                       "HAVE_.*"
                       "VA_.*"
                       ".*IEEE754.*"
                       ".*_MODIFIER"
                       
                       #;
                       ".*[A-Z].*" ;; catch-all for badly mangled names

                       ".*_copy"
                       ".*_newv"
                       ".*_valist"
                       ".*_setv"
                       ".*_user_data"
                       ".*_func"
                       ;;".*win32.*"

                       "array_.*"
                       "ascii_.*"
                       "async_queue_.*"
                       "assertion_.*"
                       "atomic_.*"

                       "base64_.*_step"
                       "bit_.*"
                       "build_.*"
                       "byte_array_.*"

                       "cache_.*"
                       "child_watch_add.*"
                       "completion_.*"
                       "convert.*"

                       "datalist_.*"
                       "dataset_.*"
                       "date_.*"
                       "dir_.*"

                       "error_.*"

                       "hash_table_.*"
                       "hook_.*"

                       "iconv.*"
                       "int_.*"

                       "key_file_.*"

                       "list_.*"
                       "log.*"

                       "malloc.*"
                       "mapped_file_.*"
                       ;; "markup_.*" ; here for now

                       "markup_collect_attributes"
                       "mem_.*"
                       "mkdir.*"

                       "node_.*"

                       "on_error_.*"
                       "option_.*"

                       "parse_debug_string"
                       "pattern_.*"
                       "printf.*"
                       "ptr_array_.*"

                       "queue_.*"

                       "rand_.*"
                       "random_.*"
                       "relation_.*"

                       "sequence_.*"
                       "scanner_.*"
                       "slice_.*"
                       "slist_.*"
                       "snprintf"
                       "source_set_callback.*"
                       "spawn_.*"
                       "static_.*"
                       "str.*"

                       "test_.*"
                       "thread_.*"
                       "time_.*"
                       "timer_.*"
                       "trash_stack_.*"
                       "tree_.*"
                       "try_.*"
                       "tuples_.*"

                       "ucs4_.*"
                       "unichar_.*"
                       "utf(8|16)_.*"

                       "access"
                       "allocator_free"
                       "assert_warning"
                       "atexit"
                       "base64_encode_close"
                       "blow_chunks"
                       "chdir"
                       "chmod"
                       "clear_error"
                       "creat"
                       "direct_equal"
                       "direct_hash"
                       "error"
                       "file_set_contents"
                       "fopen"
                       "fprintf"
                       "free"
                       "freopen"
                       "get_charset"
                       "get_filename_charsets"
                       "get_language_names"
                       "get_system_data_dirs"
                       "intern_static_string"
                       "intern_string"
                       "listenv"
                       "lstat"
                       "main_context_.*"
                       "main_loop_.*"
                       "memdup"
                       "once_impl"
                       "open"
                       "prefix_error"
                       "printerr"
                       "propagate_error"
                       "propagate_prefixed_error"
                       "qsort_with_data"
                       "quark_from_static_string"
                       "realloc"
                       "remove"
                       "rename"
                       "return_if_fail_warning"
                       "rmdir"
                       "set_error(_literal)?"
                       "set_print_handler"
                       "set_printerr_handler"
                       "shell_error_quark"
                       "shell_parse_argv"
                       "source_set_funcs"
                       "spaced_primes_closest"
                       "sprintf"
                       "stat"
                       "stpcpy"
                       "unicode_canonical_decomposition"
                       "unicode_canonical_ordering"
                       "unlink"
                       "uri_list_extract_uris"
                       "usleep"
                       "vasprintf"
                       "vfprintf"
                       "vprintf"
                       "vsprintf"
                       "vsnprintf"
                       "glib_check_version"
                       "glib_dummy_decl"

                       "Error"
                       "MainLoop"
                       "MainContext"
                       "IOChannel"
                       "dummy_decl"
                       ))
          <g-main-loop>
          <g-main-context>
          <g-io-channel>
          glib-setup!)
  (import (rnrs base)
          (only (srfi :1 lists) split-at)
          (srfi :8 receive)
          (spells tracing)
          (spells foreign)
          (sbank support utils)
          (sbank support shlibs)
          (sbank support type-data)
          (sbank ctypes call)
          (sbank typelib decorators)
          (sbank typelib)
          (only (sbank gobject internals)
                send
                make-gobject-record-class))

  (define default-prio 0)

  (define (priority-func-decorator n-args prio-pos)
    (lambda (typelib proc)
      (lambda args
        (let ((arg-count (length args)))
          (cond ((= arg-count n-args)
                 (apply proc args))
                ((= arg-count (- n-args 1))
                 (receive (front back) (split-at args prio-pos)
                   (apply proc (append front (list default-prio) back))))
                (else
                 (error "glib (function with priority)"
                        "invalid number of arguments" args)))))))


  (define (register-priority-func name n-args prio-pos)
    (register-typelib-decorator "GLib"
                                name
                                (priority-func-decorator n-args prio-pos)))

  (define-c-callouts libgthread
    (g-thread-init 'void "g_thread_init" '(pointer)))

  (define-c-callouts libglib
    (g-main-loop-ref 'pointer "g_main_loop_ref" '(pointer))
    (g-main-loop-unref 'void "g_main_loop_unref" '(pointer))
    (g-main-context-ref 'pointer "g_main_context_ref" '(pointer))
    (g-main-context-unref 'void "g_main_context_unref" '(pointer))
    (g-io-channel-ref 'pointer "g_io_channel_ref" '(pointer))
    (g-io-channel-unref 'void "g_io_channel_unref" '(pointer)))
  
  (define-setup-procedure (glib-setup!)
    (g-thread-init (null-pointer))
    (register-priority-func "io_add_watch" 4 1)
    (register-priority-func "timeout_add" 3 0)
    (register-priority-func "timeout_add_seconds" 3 0)
    (register-priority-func "idle_add" 2 0))

  
  ;; Bind some types that are not introspectable due to
  ;; <https://bugzilla.gnome.org/show_bug.cgi?id=572415>
  
  (define <g-main-loop>
    (make-gobject-record-class "GLib"
                               "MainLoop"
                               #f ;gtype
                               g-main-loop-ref
                               g-main-loop-unref
                               (lambda (class)
                                 (values `((new . ,main-loop-new))
                                         `((run . ,main-loop-run)
                                           (quit . ,main-loop-quit))))))

  (define <g-main-context>
    (make-gobject-record-class "GLib"
                               "MainContext"
                               #f ;gtype
                               g-main-context-ref
                               g-main-context-unref
                               (lambda (class)
                                 (values '() '()))))

  (define <g-io-channel>
    (make-gobject-record-class "GLib"
                               "IOChannel"
                               #f ;gtype
                               g-io-channel-ref
                               g-io-channel-unref
                               (lambda (class)
                                 (values `((unix-new . ,io-channel-unix-new)) '()))))

  (define signature:main-loop-new
    (make-signature (make-arg-info <g-main-loop> #t #f '() 'out)
                    (list (make-arg-info <g-main-context> #t #t '() 'in)
                          (make-arg-info 'boolean #f #f '() 'in))
                    #f))

  (define signature:void-0
    (make-signature (make-arg-info 'void #f #f '() 'out)
                    (list)
                    #f))

  (define signature:io-channel-unix-new
    (make-signature (make-arg-info <g-io-channel> #t #f '() 'out)
                    (list (make-arg-info 'int #f #f '() 'in))
                    #f))
  
  (define (checked-dlsym shlib symbol)
    (or (dlsym shlib symbol)
        (error 'checked-dlsym "missing symbol in shared object" shlib symbol)))
  
  (define main-loop-new
    ((signature-callout signature:main-loop-new
                         <g-main-loop>
                         (callout-options is-constructor))
     (checked-dlsym libglib "g_main_loop_new")))

  (define main-loop-run
    ((signature-callout signature:void-0 <g-main-loop> (callout-options))
     (checked-dlsym libglib "g_main_loop_run")))

  (define main-loop-quit
    ((signature-callout signature:void-0 <g-main-loop> (callout-options))
     (checked-dlsym libglib "g_main_loop_quit")))

  (define io-channel-unix-new
    ((signature-callout signature:io-channel-unix-new
                        <g-io-channel>
                        (callout-options is-constructor))
     (checked-dlsym libglib "g_io_channel_unix_new")))
  
  (typelib-import (only (prefix ("GLib" #f) g-)
                        #!@(typelib-exports glib))
                  (setup glib-setup!))

  )
