Scheme gtk-server wrapper

A gtk-server wrapper for mzscheme.

Repository URL:

Darcs command: $ darcs get


File: /

(module gtk-server mzscheme
  (require (only (lib "" "srfi") receive)
           (only (lib "" "srfi") string-join)
           (planet "" ("schematics" "macro.plt" 1 0))
           (only (lib "" "srfi") any)
           (lib ""))
  (include "")
  (include "")
  (include "")
  (include "")
  ;;   (provide with-gtk-server
  ;;            gtk-server-init
  ;;            gtk-server-exit
  ;;            defgtk
  ;;            hello-world)
  ;; just for now, fix it later
  (provide (all-defined))
    ;; Options
  (define +print-informs?+ #t) ;; Print debugging information?
  (define +gtk-server-location+ "/usr/local/bin/gtk-server")
  (define +debug+ #f) ;; Use the `log' option with gtk-server?
  (define +config-file+ "gtk-server-config.cfg")
  ;; Common Lisp-equivilant unwind-protect
  (define-syntax unwind-protect
    (syntax-rules ()
      ((unwind-protect body cleanup ...)
           (let ((ok? #t))
             (lambda ()
               (if ok? (set! ok? #f) (error))))
           (lambda () body)
           (lambda () cleanup ...)))))
  ;; Macro to initalise and to ensure the safe
  ;; de-initialisation of gtk-server.
  (define-syntax with-gtk-server
    (syntax-rules ()
      ((with-gtk-server . body)
        (when (gtk-server-valid?) (begin . body))
  ;; Gtk-server object
  ;; TODO: use define-struct or something later
  (define server '())
  ;; Accessors and methods.
  (define make-gtk-server list)
  (define gtk-server-in car)
  (define gtk-server-out cadr)
  (define gtk-server-err caddr)
  (define (gtk-server-valid?) (pair? server))
  ;; Basic information printer for debugging.
  (define (gtk-inform msg)
    (when +print-informs?+ (printf ";; ~a~n" msg)))
  ;; Throw a formatted error.
  (define (gtk-error msg)
    (error (format "gtk-server error: ~A" msg)))
  ;; Creates a gtk-server pipe according to
  ;; the +gtk-server-location+ option.
  (define (gtk-server-init)
    (gtk-inform "gtk-server-init called")
    (receive (process in out err)
      (apply subprocess                                            ;; Is this confusing? --chrisdone
             (append (list #f #f #f +gtk-server-location+ "stdin"
                           (format "cfg=~a" +config-file+))
                     (if +debug+ '("log") '())))
      (if (and (subprocess? process)
               (eq? (subprocess-status process) 'running))
          (begin (set! server (make-gtk-server in out err))
                 (unless (gtk-ok? (gtk-init "NULL" "NULL"))
                   (gtk-error "Unable to initialise gtk.")))
          (begin (gtk-clean)
                 (gtk-error (format "Unable to execute gtk-server process."))))))
  ;; Send the `gtk_exit' command to gtk-server,
  ;; which closes the pipe, and then clean the ports.
  (define (gtk-server-exit)
    (gtk-inform "gtk-server-exit called")
    (when (gtk-server-valid?)
      (gtk-exit 0)
  ;; If the gtk-server pipe is open, close all the ports
  ;; and clear the server structure.
  (define (gtk-clean)
    (gtk-inform "gtk-clean called.")
    (when (gtk-server-valid?)
      (close-input-port (gtk-server-in server))
      (close-input-port (gtk-server-err server))
      (close-output-port (gtk-server-out server))
      (set! server '())))
  ;; Did gtk-server respond with success?
  (define (gtk-ok? ret)
    (and (string? ret) (string=? ret "ok")))
  (define (gtk-symbol->string sym)
    (regexp-replace* "-" (symbol->string sym)
  ;; Raw pipe communication functions.
  ;; Wouldn't mind these in a separate module either... --chrisdone
  ;; Outputs a command and returns the
  ;; "result" (gtk-server's response).
  (define (gtk-out-in str)
    (gtk-out str)
  ;; Outputs raw text to gtk-server.
  (define (gtk-out str)
    (gtk-inform (format "gtk-out: ~A" str))
    (fprintf (gtk-server-out server) "~A\n" str)
    (flush-output (gtk-server-out server)))
  ;; Reads from gtk-server.
  (define (gtk-in)
    (let ((line (read-line (gtk-server-in server))))
      (gtk-inform (format "gtk-in: ~A" line))
  ;; Sends output to gtk-server-out.
  (define (gtk-send func . args)
    (gtk-out-in (string-join (append (list func) args) " ")))
  (define (gtk-event-loop . handlers)
    (let loop ((event (gtk-server-callback "WAIT")))
      (gtk-inform (format "event: ~a" event))
      (aif handler (any (lambda (x) (if (eq? event (car x)) (cdr x) #f)) handlers)
        (when (handler) (loop (gtk-server-callback "WAIT")))
        (loop (gtk-server-callback "WAIT")))))
  (define (gtk-box-pack-startv vbox widgets)
    (for-each (lambda (x) (apply gtk-box-pack-start
                                 (append (list vbox) x)))