263 lines
8.9 KiB
Scheme
263 lines
8.9 KiB
Scheme
;;;; 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:inherits
|
|
<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-layout> (% <qt-object> (class 'qt-layout)))
|
|
|
|
(define (qt:->pointer i) (and i (? i pointer)))
|
|
(define (qt:pointer->widget p) (and p (% <qt-widget> (pointer p))))
|
|
(define (qt:pointer->layout p) (and p (% <qt-layout> (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 qtlayout c-pointer qt:->pointer qt:pointer->layout)
|
|
(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:find
|
|
(let ((qt:find qt:find))
|
|
(lambda (o name)
|
|
(let ((result (qt:find o name)))
|
|
(if result
|
|
(cond ((qt:inherits result "QTextEdit")
|
|
(qt:pointer->textedit (qt:->pointer result)))
|
|
((qt:inherits result "QWidget")
|
|
(qt:pointer->widget (qt:->pointer result)))
|
|
((qt:inherits result "QAction")
|
|
(qt:pointer->action (qt:->pointer result)))
|
|
((qt:inherits result "QLayout")
|
|
(qt:pointer->layout (qt:->pointer result)))
|
|
(#t
|
|
result))
|
|
result)))))
|
|
|
|
(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 ((qt:inherits w "QComboBox") (qt:addcomboboxitem w x))
|
|
((qt:inherits w "QListWidget") (qt:addlistwidgetitem w x))
|
|
((qt:inherits w "QTreeWidget") (qt:addtreewidgetitem w x))
|
|
((qt:inherits w "QLayout") (qt:addlayoutwidget 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)
|
|
|
|
)
|