Scheme gtk-server wrapper

A gtk-server wrapper for mzscheme.

Repository URL:

Darcs command: $ darcs get


File: /

(require (only (lib "" "srfi") make-list))
;; Defines a function of name `name-lisp' which sends
;; the gtk version of that name and parameters to gtk-server.
;; Example: gtk-init => "gtk_init"
(define-syntax defgtk
  (syntax-rules ()
    ((defgtk name return-type args-and-types)
     (define (name . args)
       (if (= (length args) (length 'args-and-types))
            (apply gtk-send
                   (append (list (gtk-symbol->string 'name))
                           (map (lambda (arg arg-and-type)
                                  (gtk-coerce-type arg (cadr arg-and-type)))
           (error (format "arity mismatch for ~a: expects ~a arguments, given ~a"
                          'name (length args) (length 'args-and-types))))))))
(define (gtk-coerce-type obj type) 
  (case type
    ('string  (any->string obj))
    (else (format "~a" obj))))
(define (any->string obj)
  (cond ((string? obj) (format-string obj))
        (else (format "\"~a\"" obj))))
(define (format-string text)
  (let* ((text (regexp-replace* #rx"\n" text "\\\\n"))
         (final-text (regexp-replace* #rx"\"" text "\\\\\"")))
    (format "\"~A\"" final-text)))
(defgtk g-malloc widget ((size number)))
(defgtk g-free none ((_ widget)))
;; Gtk functions
(defgtk gtk-init string ((argc number) (argv number)))
;; Gtk-server-specific functions
(defgtk gtk-server-callback widget ((_ number)))
(defgtk gtk-exit none ((argv number)))
(defgtk gtk-server-version string ())
;; Button widget functions
(defgtk gtk-button-new widget ())
(defgtk gtk-button-new-with-label widget ((label string)))
(defgtk gtk-button-new-with-mnemonic widget ((label string)))
(defgtk gtk-button-new-from-stock widget ((id string)))
(defgtk gtk-button-pressed none ((button widget)))
(defgtk gtk-button-released none ((button widget)))
(defgtk gtk-button-clicked none ((button widget)))
(defgtk gtk-button-enter none ((button widget)))
(defgtk gtk-button-leave none ((button widget)))
;; TODO: define these constants with some enum macro
(define +gtk-relief-normal+ 0)
(define +gtk-relief-half+ 1)
(define +gtk-relief-none+ 2)
(defgtk gtk-button-set-relief none ((button widget) (newstyle long)))
(defgtk gtk-button-get-relief integer (button widget))
(defgtk gtk-button-get-label string ((button widget)))
(defgtk gtk-button-set-label none ((button widget) (label string)))
(defgtk gtk-button-get-use-stock boolean ((button widget)))
(defgtk gtk-button-set-use-stock none ((button widget) (use-stock boolean)))
(defgtk gtk-button-get-use-underline boolean ((button widget)))
(defgtk gtk-button-set-use-underline none ((button widget) (use-underline boolean)))
(defgtk gtk-button-set-focus-on-click none ((button widget) (focus-on-click boolean)))
(defgtk gtk-button-get-focus-on-click boolean ((button widget)))
(defgtk gtk-button-set-alignment none ((button widget) (x float) (y float)))
;; Unable to support this?
;;void                gtk_button_get_alignment            (GtkButton *button,
;;                                                         gfloat *xalign,
;;                                                         gfloat *yalign);
(defgtk gtk-button-set-image none ((button widget) (button widget)))
(defgtk gtk-button-get-image widget ((button widget)))
(define +gkt-pos-left+ 0)
(define +gtk-pos-right+ 1)
(define +gtk-pos-top+ 2)
(define +gtk-pos-bottom+ 3)
(defgtk gtk-button-set-image-position none ((button widget) (position integer)))
(defgtk gtk_button-get-image-position integer ((button widget)))
;; Gtk list store
(define (type->gtk-server-type type)
  (case type
    ('string "64")
    (else "64")))
(define (gtk-redefine-list columns)
  (let* ((types (string-join (make-list (length columns) "LONG") " "))
         (redefine (format "gtk_server_redefine gtk_list_store_new NONE WIDGET ~a LONG ~a"
                           (+ (length columns) 1) types)))
    (gtk-out-in redefine)))
(define (gtk-new-list columns)
  (let* ((args (string-join (map type->gtk-server-type columns) " "))
         (command (format "gtk_list_store_new ~a ~a" (length columns) args)))
    (gtk-out-in command)))
(define (gtk-list-store-new . columns)
  (gtk-redefine-list columns)
  (gtk-new-list columns))
 ;;; Unorganised functions
(defgtk gtk-window-new widget ((type integer)))
(defgtk gtk-window-set-title none ((window widget)(title string)))
(defgtk gtk-window-set-transient-for none ((window widget) (child widget)))
(defgtk gtk-vbox-new widget ((homogeneus boolean) (spacing integer)))
(defgtk gtk-hbox-new widget ((homogeneus boolean) (spacing integer)))
(defgtk gtk-container-add none ((container widget) (child widget)))
(defgtk gtk-combo-box-new-text widget ())
(defgtk gtk-box-pack-start none ((box widget) (child widget) (expand boolean)
				 (fill boolean) (padding integer)))
(defgtk gtk-box-pack-end none ((box widget) (child widget) (expand boolean)
			       (fill boolean) (padding integer)))
(defgtk gtk-text-view-new widget ())
(defgtk gtk-label-new widget ((text string)))
(defgtk gtk-entry-new widget ())
(defgtk gtk-widget-show-all none ((what widget)))
(defgtk gtk-widget-destroy none ((what widget)))
(defgtk gtk-entry-get-text string ((w widget)))
(defgtk gtk-entry-set-text none ((what widget) (text string)))
(defgtk gtk-combo-box-append-text none ((w widget) (what string)))
(defgtk gtk-combo-box-get-active-text string ((w widget)))
(defgtk gtk-combo-box-set-active none ((w widget) (index integer)))
(defgtk gtk-combo-box-remove-text none ((w widget) (what integer)))
(defgtk gtk-combo-box-get-active integer ((w widget)))
(defgtk gtk-text-buffer-get-start-iter none ((what widget) (iter widget)))
(defgtk gtk-text-buffer-get-end-iter none ((what widget) (iter widget)))
(defgtk gtk-text-view-get-buffer widget ((what widget)))
(defgtk gtk-text-view-set-editable none ((what widget) (status boolean)))
(defgtk gtk-text-buffer-get-text string ((what widget) (iter-start widget) (iter-end widget) (hidden-char boolean)))
(defgtk gtk-text-buffer-insert none ((what widget) (iter widget) (cosa string) (length integer)))
(defgtk gtk-text-buffer-get-insert widget ((buffer widget)))
(defgtk gtk-text-buffer-insert-at-cursor none ((buffer widget) (text string) (len integer)))
(defgtk gtk-text-view-scroll-to-mark none ((text-view widget)
                                           (mark widget)
                                           (within-margin float)
                                           (use-align boolean)
                                           (xalign float)
                                           (yalign float)))
(defgtk gtk-frame-new widget ())
(defgtk gtk-server-enable-c-string-escaping none ())
(defgtk gtk-text-buffer-set-text none ((what widget) (text string) (length integer)))
(defgtk gtk-scrolled-window-new widget ())
(defgtk gtk-table-new widget ((rows integer) (cols integer) (homogeneus boolean)))
(defgtk gtk-table-attach-defaults none
	      ((container widget) (child widget) (left integer) (right integer) 
	       (top integer) (bottom integer)))
(defgtk gtk-misc-set-alignment none ((what widget) (xalign float) (yalign float)))
(defgtk gtk-label-set-use-markup none ((what widget) (status boolean)))
(defgtk gtk-frame-set-label none ((what widget) (label string)))
(defgtk gtk-message-dialog-new widget ((parent widget)
				      (flags integer)
				      (type integer)
				      (buttons integer)
				      (message string)))
(defgtk gtk-dialog-run integer ((what widget)))
(defgtk gtk-window-set-default-size none ((win widget) (width integer) (height integer)))
(defgtk gtk-menu-bar-new widget ())
(defgtk gtk-menu-shell-append none ((where widget) (child widget)))
(defgtk gtk-menu-item-new widget ())
(defgtk gtk-menu-item-new-with-label widget ((label string)))
(defgtk gtk-menu-item-new-with-mnemonic widget ((label string)))
(defgtk gtk-menu-new widget ())
(defgtk gtk-menu-item-set-right-justified none ((what widget) (status boolean)))
(defgtk gtk-menu-item-set-submenu none ((what widget) (submenu widget)))
(defgtk gtk-check-menu-item-new-with-label widget ((label string)))
(defgtk gtk-check-menu-item-get-active integer ((what widget)))
(defgtk gtk-image-new widget ())
(defgtk gtk-image-new-from-pixmap widget ((pixmap widget) (bitmap widget)))
(defgtk gtk-image-set-from-file none ((image widget) (filename string)))
(defgtk gtk-image-new-from-file widget ((filename string)))
(defgtk gtk-file-chooser-dialog-new widget ((title string)
					    (parent widget)
					    (action integer)
					    (first-button-label string)
					    (first-button-response integer)
					    (second-button-label string)
					    (second-button-response integer)))
(defgtk gtk-file-chooser-widget-new widget ((action integer)))
(defgtk gtk-file-chooser-get-filename string ((dialog widget)))
(defgtk gtk-file-chooser-set-filename boolean ((dialog widget) (filename string)))
(defgtk gtk-file-filter-new widget ())
(defgtk gtk-file-filter-add-pattern none ((filter widget) (string pattern)))
(defgtk gtk-file-filter-set-name none ((filter widget) (name string)))
(defgtk gtk-file-chooser-add-filter none ((chooser widget) (filter widget)))
(defgtk gtk-cell-renderer-text-new widget ())
(defgtk gtk-list-store-append none ((store widget) (iter widget)))
(defgtk gtk-list-store-iter-is-valid integer ((store widget) (iter widget)))
(defgtk gtk-list-store-clear none ((store widget)))
(defgtk gtk-list-store-set none ((store widget) (iter widget) (column integer)
 								 (value string) (terminator integer)))
(defgtk gtk-tree-model-get-string-from-iter string ((model widget) (iter widget)))
(defgtk gtk-tree-selection-set-mode none ((tv widget) (mode integer)))
(defgtk gtk-tree-view-get-selection widget ((tv widget)))
(defgtk gtk-tree-view-new widget ())
(defgtk gtk-tree-view-insert-column-with-attributes integer
  ((tv widget) (pos integer) (title string) (renderer widget) 
   (attribute string) (index integer) (terminator integer)))
(defgtk gtk-tree-view-get-model widget ((tv widget)))
(defgtk gtk-tree-view-set-model none ((tv widget) (model widget)))
(defgtk gtk-tree-selection-get-selected integer ((sel widget) (model widget) (row widget)))
(defgtk g-object-unref none ((obj widget)))
(defgtk g-object-ref-sink none ((obj widget)))
(defgtk gtk-tree-view-get-column widget ((tv widget) (column integer)))
(defgtk gtk-tree-view-column-get-width integer ((column widget)))
(defgtk gtk-tree-view-column-get-fixed-width integer ((column widget)))
(defgtk gtk-tree-view-column-set-fixed-width none ((column widget) (width integer)))
(defgtk gtk-tree-view-column-set-min-width none ((column widget) (width integer)))
(defgtk gtk-tree-view-column-get-min-width integer ((column widget)))
(defgtk gtk-tree-view-column-set-max-width none ((column widget) (width integer)))
(defgtk gtk-tree-view-column-get-max-width integer ((column widget)))
(defgtk gtk-tree-view-column-set-sizing none ((column widget) (sizing integer)))
(defgtk gtk-tree-view-column-get-sizing integer ((column widget)))
(defgtk gtk-window-set-modal none ((win widget) (modal integer)))
(defgtk gtk-widget-set-size-request none ((widget widget) (width integer) (height integer)))
(defgtk gtk-widget-set-usize none ((widget widget) (width integer) (height integer)))
(defgtk gtk-widget-set-name none ((widget widget) (name string)))
(defgtk gtk-rc-parse-string none ((rc-string string)))
(defgtk gtk-hpaned-new widget ())
(defgtk gtk-vpaned-new widget ())
(defgtk gtk-paned-add1 none ((widget widget) (child widget)))
(defgtk gtk-paned-add2 none ((widget widget) (child widget)))
(defgtk gtk-paned-pack1 none ((widget widget) (child widget) (resize boolean) (shrink boolean)))
(defgtk gtk-paned-pack2 none ((widget widget) (child widget) (resize boolean) (shrink boolean)))
(defgtk g-object-set none ((obj widget) (property string) (val integer) (null integer)))