Scheme gtk-server wrapper

A gtk-server wrapper for mzscheme.

Repository URL:

Darcs command: $ darcs get


File: /

(require (lib "" "srfi"))
;; list-view accessors
(define list-view-widget car)
(define list-view-data caddr)
;; list-view is just a list atm.  use records or structs or something later
(define (make-list-view . columns)
  (if (eq? (length columns) 0)
	  (error "list-view: cannot create a list-view with no columns")
	  (let ((widget (gtk-tree-view-new))
			(model (apply gtk-list-store-new columns)))
		;; Fill the columns
		(let set-next ((columns columns) (count 0))
		  (unless (null? columns)
			(let ((renderer (gtk-cell-renderer-text-new)))
			  (g-object-set renderer "editable" 1 0)
			  (gtk-tree-view-insert-column-with-attributes widget -1
														   (car columns) renderer
														   "text" count
			(set-next (cdr columns) (add1 count))))
		;; Set the model
		(gtk-tree-view-set-model widget model)
		(let loop ((count (length columns)))
		  (gtk-tree-view-column-set-sizing (gtk-tree-view-get-column widget
																	 (- count 1))
										   1)) ; 1 is +gtk-tree-view-column-autosize+
		;; Set a single mode selection
		(gtk-tree-selection-set-mode (gtk-tree-view-get-selection widget)
									 1) ; 1 is +gtk-selection-single+
		(g-object-unref model)
		(list widget columns (make-hash-table 'equal)))))
(define (list-view-add-row lst-view . text)
  (let ((row (gtk-frame-new))
		(model (gtk-tree-view-get-model (list-view-widget lst-view))))
	(gtk-list-store-append model row)
	(let set-next ((text text) (number 0))
	  (unless (null? text)
		(gtk-list-store-set model row number (car text) -1)
		(set-next (cdr text) (add1 number))))
	;; Store data in the hash-table
	(let ((key (format "~a:~a" model row))
		  (value text))
	  (hash-table-put! (list-view-data lst-view)
					   key value))))