qt-light/qt-light.scm

;;;; qt-light.scm


(module qt-light (qt:init 
		  qt:widget qt:show qt:hide qt:run
		  qt:delete qt:message qt:connect qt:find
		  qt:widget qt:receiver qt:pixmap qt:icon qt:theme-icon qt:timer
          qt:icon->pixmap qt:pixmap->icon
		  qt:property qt:gl qt:update qt:start qt:stop
		  qt:clear qt:add qt:item <qt> qt:classname
		  <qt-object> <qt-widget> <qt-pixmap> <qt-icon> <qt-application>
		  <qt-receiver> <qt-timer> <qt-sound> <qt-text-edit>
		  <qt-action>
		  qt:get-open-filename qt:get-save-filename qt:get-directory
		  qt:sound qt:play qt:set-headers
		  qt:selection qt:insert
		  qt:shortcut
		  qt:add-action qt:remove-action
		  qt:char-encoding)

(import
  scheme
  (chicken base)
  (chicken bitwise)
  (chicken foreign)
  (chicken format)
  (chicken fixnum)
  (chicken string)
  bind
  miscmacros
  srfi-4 srfi-1 protobj matchable
  )


(define <qt>
  (% (current-root-object) 
     (class '<qt>)
     (pointer #f)
     (print (lambda (self #!optional (port (current-output-port)))
	      (fprintf port "#<~a>" (? self class))))))

(define <qt-object> (% <qt> (class 'qt-object)))
(define <qt-sound> (% <qt-object> (class 'qt-sound)))
(define <qt-widget> (% <qt-object> (class 'qt-widget)))
(define <qt-application> (% <qt-object> (class 'qt-application)))
(define <qt-pixmap> (% <qt> (class 'qt-pixmap)))
(define <qt-icon> (% <qt> (class 'qt-icon)))
(define <qt-receiver> (% <qt-object> (class 'qt-receiver)))
(define <qt-timer> (% <qt-object> (class 'qt-timer)))
(define <qt-text-edit> (% <qt-widget> (class 'qt-text-edit)))
(define <qt-action> (% <qt-object> (class 'qt-action)))

(define (qt:->pointer i) (and i (? i pointer)))
(define (qt:pointer->widget p) (and p (% <qt-widget> (pointer p))))
(define (qt:pointer->object p) (and p (% <qt-object> (pointer p))))
(define (qt:pointer->timer p) (and p (% <qt-timer> (pointer p))))
(define (qt:pointer->application p) (and p (% <qt-application> (pointer p))))
(define (qt:pointer->pixmap p) (and p (% <qt-pixmap> (pointer p))))
(define (qt:pointer->icon p) (and p (% <qt-icon> (pointer p))))
(define (qt:pointer->receiver p) (and p (% <qt-receiver> (pointer p))))
(define (qt:pointer->sound p) (and p (% <qt-sound> (pointer p))))
(define (qt:pointer->text-edit p) (and p (% <qt-text-edit> (pointer p))))
(define (qt:pointer->action p) (and p (% <qt-action> (pointer p))))


(bind-rename/pattern "qt_" "qt:")
(bind-type qtwidget c-pointer qt:->pointer qt:pointer->widget)
(bind-type qtapplication c-pointer qt:->pointer qt:pointer->application)
(bind-type qtpixmap c-pointer qt:->pointer qt:pointer->pixmap)
(bind-type qticon c-pointer qt:->pointer qt:pointer->icon)
(bind-type qtobject c-pointer qt:->pointer qt:pointer->object)
(bind-type qttimer c-pointer qt:->pointer qt:pointer->timer)
(bind-type qtreceiver c-pointer qt:->pointer qt:pointer->receiver)
(bind-type qtsound c-pointer qt:->pointer qt:pointer->sound)
(bind-type qttextedit c-pointer qt:->pointer qt:pointer->text-edit)
(bind-type qtaction c-pointer qt:->pointer qt:pointer->action)

#>
#define ___safe
#define ___bool         int
#define ___out
<#

#>
extern "C" {
	    #include "prototypes.h"
	    }
<#

(bind-file*  "prototypes.h")

(define-enum encoding->int int->encoding
  unused latin1 utf8 ascii)

(define (qt:char-encoding #!optional enc)
  (if enc
      (qt:charencoding 
       (or (encoding->int enc)
	   (error 'qt:char-encoding "invalid encoding mode" enc)))
      (int->encoding (qt:charencoding 0))))

(define qt:connect
  (let ((qt:connect qt:connect))
    (lambda (from sig to #!optional (slot "slot()"))
      (qt:connect 
       from (string-append "2" sig)
       (if (procedure? to) (qt:receiver to) to)
       (string-append "1" slot)) ) ) )

(define qt:receiver
  (let ((qt:receiver qt:receiver))
    (lambda (thunk #!optional (name (gensym "qt:receiver")))
      (qt:receiver (->string name) thunk) ) ) )

(! <qt-object> 'delete
   (lambda (self) (qt:deleteobject self)))

(! <qt-pixmap> 'delete
   (lambda (self) (qt:deletepixmap self)))

(! <qt-icon> 'delete
   (lambda (self) (qt:deleteicon self)))

(define (qt:delete o) (@ delete o))

(define qt:theme-icon qt:themeicon)

(define qt:icon->pixmap qt:icontopixmap)

(define qt:pixmap->icon qt:pixmaptoicon)

(define qt:message
  (let ((qt:message qt:message))
    (lambda (text #!key (caption "") (title "") parent
                  (button1 "OK") (button2 "Cancel") button3
                  (type 'information))
      (qt:message (or title caption) text parent button1 button2 button3
                  (case type
                    ['information 3]
                    ['question 1]
                    ['warning 2]
                    ['critical 3])))))

(define (qt:widget fname #!optional parent)
  (qt:create fname parent) )

(define qt:property
  (getter-with-setter
   (lambda (w p) 
     (let ((p (->string p)))
       (case (qt:propertytype w p)
	 ((5) (qt:getstringproperty w p))
	 ((4) (qt:getintproperty w p))
	 ((3) (qt:getfloatproperty w p))
	 ((1) (qt:getboolproperty w p))
	 ((2) (integer->char (qt:getcharproperty w p)))
	 ((6) (qt:getpixmapproperty w p))
	 ((7) (qt:getpointfproperty w p (make-f64vector 2)))
	 ((8) (qt:getrectfproperty w p (make-f64vector 4)))
	 ((9) (qt:getsizefproperty w p (make-f64vector 2)))
	 ((10) (qt:getpointproperty w p (make-s32vector 2)))
	 ((11) (qt:getsizeproperty w p (make-s32vector 2)))
	 ((12) (qt:getrectproperty w p (make-s32vector 4)))
	 (else (error "unknown property" w p)) ) ) )
   (lambda (w p x)
     (let* ((p (->string p))
	    (ok (cond ((string? x) (qt:setstringproperty w p x))
		      ((fixnum? x) (qt:setintproperty w p x))
		      ((flonum? x) (qt:setfloatproperty w p x))
		      ((char? x) (qt:setcharproperty w p x))
		      ((boolean? x) (qt:setboolproperty w p x))
		      ((s32vector? x)
		       (if (fx= (s32vector-length x) 2)
			   (qt:setpointproperty w p x)
			   (qt:setrectproperty w p x) ) )
		      ((f64vector? x)
		       (if (fx= (f64vector-length x) 2)
			   (qt:setpointfproperty w p x)
			   (qt:setrectfproperty w p x) ) )
		      ((eq? (? x class) 'qt-pixmap) (qt:setpixmapproperty w p x))
		      (else (error "unknown property" w p)) ) ) )
       (unless ok (error 'qt:property/setter "unable to set widget property" w p x) ) ) ) ) )

(define qt:gl
  (let ((qt:gl qt:gl))
    (lambda (name parent init resize paint)
      (qt:gl
       name parent
       (match-lambda*
	 ((0) (init))
	 ((1 w h) (resize w h))
	 (_ (paint)) ) ) ) ) )

(define qt:run
  (let ((qt:run qt:run))
    (lambda (#!optional once)
      (qt:run once) ) ) )

(define (qt:add w x)
  (cond ((string=? "QComboBox" (qt:classname w)) (qt:addcomboboxitem w x))
	((string=? "QListWidget" (qt:classname w)) (qt:addlistwidgetitem w x))
	((string=? "QTreeWidget" (qt:classname w)) (qt:addtreewidgetitem w x))
	(else (error 'qt:add "invalid widget" w x)) ) )

(define (qt:item w i) (and (positive? i) (qt:listwidgetitem w i)))
(define qt:clear qt:clearlistwidget)

(define (qt:set-headers w x)
  (cond ((string=? "QTreeWidget" (qt:classname w)) (qt:setheaders w x))
	(else (error 'qt:set-headers "invalid widget" w x)) ) )

(define (file-dialog-options loc os)
  (let loop ((os os))
    (cond ((null? os) 0)
	  ((assq (car os)
		 '((show-dirs-only: . 1) (dont-resolve-symlinks: . 2) (dont-confirm-overwrite: . 4)
		   (dont-use-sheet: . 8) (dont-use-native-dialog: . 16) ) )
	   => (lambda (a) (loop (bitwise-ior (cdr a) (loop (cdr os))))) )
	  (else (error loc "invalid file-dialog option" (car os))) ) ) )

(define (qt:get-open-filename cap dir #!key parent (options '()) filter)
  (qt:getopenfilename parent cap dir filter (file-dialog-options 'qt:get-open-filename options)) )

(define (qt:get-save-filename cap dir #!key parent (options '()) filter)
  (qt:getsavefilename parent cap dir filter (file-dialog-options 'qt:get-save-filename options)) )

(define (qt:get-directory cap dir #!key parent (options '()))
  (qt:getexistingdirectory parent cap dir (file-dialog-options 'qt:get-directory options)) )

(! <qt-timer> stop
   (lambda (self) (qt:stoptimer self)))

(! <qt-sound> stop
   (lambda (self) (qt:stopsound self)))

(define (qt:stop x) (@ x stop))

(define qt:add-action qt:addaction)
(define qt:remove-action qt:removeaction)

)