;;;; 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:timer
		  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-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 
	(except foreign foreign-declare)
	easyffi
	miscmacros)
(use srfi-4 srfi-1 protobj matchable data-structures extras)

(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-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->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))))

#>?
___declare(substitute, "qt_;qt:")
___declare(type, "qtwidget;c-pointer;qt:->pointer;qt:pointer->widget")
___declare(type, "qtapplication;c-pointer;qt:->pointer;qt:pointer->application")
___declare(type, "qtpixmap;c-pointer;qt:->pointer;qt:pointer->pixmap")
___declare(type, "qtobject;c-pointer;qt:->pointer;qt:pointer->object")
___declare(type, "qttimer;c-pointer;qt:->pointer;qt:pointer->timer")
___declare(type, "qtreceiver;c-pointer;qt:->pointer;qt:pointer->receiver")
___declare(type, "qtsound;c-pointer;qt:->pointer;qt:pointer->sound")
___declare(type, "qttextedit;c-pointer;qt:->pointer;qt:pointer->text-edit")
___declare(type, "qtaction;c-pointer;qt:->pointer;qt:pointer->action")
<#

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

#>?
#include "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)))

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

(define qt:message
  (let ((qt:message qt:message))
    (lambda (text #!key (caption "") parent (button1 "OK") (button2 "Cancel") button3)
      (qt:message caption text parent button1 button2 button3) ) ) )

(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)

)