diff --git a/qml.core.scm b/qml.core.scm index 9bfabe5..5c9425e 100644 --- a/qml.core.scm +++ b/qml.core.scm @@ -1,48 +1,82 @@ +;; -*- geiser-scheme: chicken -*- (module (qml core) * (import (scheme base)) (import (chicken gc)) (import (chicken string)) + (import (chicken base)) + (import (chicken condition)) (import (qml lowlevel)) - (import coops coops-primitive-objects coops-extras) + (import coops coops-primitive-objects coops-extras srfi-1 srfi-69) ;; Enums (define-class () - ((value accessor: value))) + ((val accessor: val))) (define-class ()) - (define (qevent-loop-process-event-flag value) - (case value + (define (qevent-loop-process-event-flag val) + (case val ((process-all-events:) - (make 'value DosQEventLoopProcessEventFlagProcessAllEvents)) + (make 'val DosQEventLoopProcessEventFlagProcessAllEvents)) ((exclude-user-input-events:) - (make 'value DosQEventLoopProcessEventFlagExcludeUserInputEvents)) + (make 'val DosQEventLoopProcessEventFlagExcludeUserInputEvents)) ((process-exclude-socket-notifiers:) - (make 'value DosQEventLoopProcessEventFlagProcessExcludeSocketNotifiers)) + (make 'val DosQEventLoopProcessEventFlagProcessExcludeSocketNotifiers)) ((process-all-events-wait-for-more-events:) - (make 'value DosQEventLoopProcessEventFlagProcessAllEventsWaitForMoreEvents)))) + (make 'val DosQEventLoopProcessEventFlagProcessAllEventsWaitForMoreEvents)))) (define-class ()) - (define (qt-connection-type value) - (case value + (define (qt-connection-type val) + (case val ((auto:) - (make 'value DosQtConnectionTypeAutoConnection)) + (make 'val DosQtConnectionTypeAutoConnection)) ((direct:) - (make 'value DosQtConnectionTypeDirectConnection)) + (make 'val DosQtConnectionTypeDirectConnection)) ((queued:) - (make 'value DosQtConnectionTypeQueuedConnection)) + (make 'val DosQtConnectionTypeQueuedConnection)) ((blocking:) - (make 'value DosQtConnectionTypeBlockingConnection)) + (make 'val DosQtConnectionTypeBlockingConnection)) ((unique:) - (make 'value DosQtConnectionTypeUniqueConnection)))) + (make 'val DosQtConnectionTypeUniqueConnection)))) + + (define-class ()) + (define (qquick-view-resize-mode val) + (case val + ((size-view-to-root-object:) (make 'val #x0)) + ((size-root-object-to-view:) (make 'val #x1)))) + + (define-class ()) + (define (qitem-data-role val) + (case val + ((display:) (make 'val 0)) + ((decoration:) (make 'val 1)) + ((edit:) (make 'val 2)) + ((tool-tip:) (make 'val 3)) + ((status-tip:) (make 'val 4)) + ((whats-this:) (make 'val 5)) + ((font:) (make 'val 6)) + ((text-alignment:) (make 'val 7)) + ((background:) (make 'val 8)) + ((foreground:) (make 'val 9)) + ((check-state:) (make 'val 10)) + ((accessible-text:) (make 'val 11)) + ((accessible-description:) (make 'val 12)) + ((size-hint:) (make 'val 13)) + ((initial-sort-order:) (make 'val 14)))) + + (define-class ()) + (define (qt-orientation val) + (case val + ((horizontal:) (make 'val #x01)) + ((vertical:) (make 'val #x02)))) ;; Helpers (define (application-dir-path) (dos_qcoreapplication_application_dir_path)) (define-method (process-events (flag )) - (dos_qcoreapplication_process_events (value flag))) + (dos_qcoreapplication_process_events (val flag))) (define-method (process-events-timed (flag ) (timed )) - (dos_qcoreapplication_process_events_timed (value flag) timed)) + (dos_qcoreapplication_process_events_timed (val flag) timed)) (define (gui-application-create) (dos_qguiapplication_create)) @@ -68,26 +102,96 @@ (dos_qquickstyle_set_fallback_style style)) ;; Objects - (define-class () - ((ptr accessor: ptr))) + (define callback-registry + (make-hash-table)) + + (define-method (refcount (alist )) + (cdr (find (lambda (a) (eq? refcount: (car a))) alist))) + (define-method (refcount (ht ) (ptr )) + (if (hash-table-exists? callback-registry ptr) + (refcount (hash-table-ref ht ptr)) + 0)) + + (define-class () + ((ptr accessor: ptr initform: #f))) + (define-method (delete-pointer (qbase )) + (abort (make-property-condition 'exn 'Message "Please implement the delete method for your subtype."))) + (define-method (add-ptrentry (qbase )) + (hash-table-update! callback-registry (ptr qbase) + (lambda (alist) + (alist-update refcount: (+ 1 (refcount alist)) alist)) + (lambda () + (alist-cons refcount: 1 '())))) + (define-method (remove-ptrentry (qbase )) + (if (eq? 1 (refcount callback-registry (ptr qbase))) + (hash-table-delete! callback-registry (ptr qbase)) + (hash-table-update! callback-registry (ptr qbase) + (lambda (alist) + (alist-update refcount: (- (refcount alist) 1) alist))))) + (define-method (initialize-instance (qbase )) + (call-next-method) + (add-ptrentry qbase) + (set-finalizer! qbase (lambda (obj) + (remove-ptrentry qbase) + (when (= 0 (refcount callback-registry (ptr qbase))) + (delete-pointer qbase))))) + + (define-class ()) (define-method (signal-emit (qo ) (name ) (paramcount ) (parameters )) (dos_qobject_signal_emit (ptr qo) name paramcount parameters)) - (define-method (delete (qo )) + (define-method (delete-pointer (qo )) (dos_qobject_delete (ptr qo))) - (define-method (delete-later (qo )) + (define-method (delete-pointer-later (qo )) (dos_qobject_deleteLater (ptr qo))) - (define-class () + (define-class () ((ptr accessor: ptr))) + (define-method (initialize-instance (qv )) + (set! (ptr qv) (dos_qvariant_create)) + (call-next-method)) + (define-method (qvariant (val )) + (make 'ptr (dos_qvariant_create_int val))) + (define-method (qvariant (val )) + (make 'ptr (dos_qvariant_create_bool val))) + (define-method (qvariant (val )) + (make 'ptr (dos_qvariant_create_string val))) + (define-method (qvariant (val )) + (make 'ptr (dos_qvariant_create_qobject (ptr val)))) + (define-method (qvariant (val )) + (make 'ptr (dos_qvariant_create_float val))) + (define-method (set (qv ) (val )) + (dos_qvariant_setInt (ptr qv) val)) + (define-method (set (qv ) (val )) + (dos_qvariant_setBool (ptr qv) val)) + (define-method (set (qv ) (val )) + (dos_qvariant_setFloat (ptr qv) val)) + (define-method (set (qv ) (val )) + (dos_qvariant_setString (ptr qv) val)) + (define-method (set (qv ) (val )) + (dos_qvariant_setQObject (ptr qv) (ptr val))) + (define-method (to (qv ) (target )) + (case target + ((integer:) (dos_qvariant_toInt (ptr qv))) + ((boolean:) (dos_qvariant_toBool (ptr qv))) + ((string:) (dos_qvariant_toString (ptr qv))) + ((flonum:) (dos_qvariant_toFloat (ptr qv))) + ((qobject:) (dos_qvariant_toQObject (ptr qv))))) + (define-method (is-null? (qv )) + (dos_qvariant_isnull (ptr qv))) + (define-method (assign (qv ) (other )) + (dos_qvariant_assign (ptr qv) (ptr other))) + (define-method (copy (qv )) + (make 'ptr (dos_qvariant_create_qvariant (ptr qv)))) + (define-method (delete-pointer (qv )) + (dos_qvariant_delete (ptr qv))) (define-class ()) (define-method (base-url (context )) (dos_qqmlcontext_baseUrl (ptr context))) - (define-method (set-property (context ) (name ) (value )) - (dos_qqmlcontext_setcontextproperty (ptr context) name (ptr value))) + (define-method (set-property (context ) (name ) (qvalue )) + (dos_qqmlcontext_setcontextproperty (ptr context) name (ptr qvalue))) - (define-class () - ((ptr accessor: ptr))) + (define-class ()) (define (new-QUrl url) (let ((qurl (make 'ptr (dos_qurl_create url 0)))) qurl)) @@ -95,13 +199,13 @@ (dos_qurl_to_string (ptr qurl))) (define-method (valid? (qurl )) (dos_qurl_isValid (ptr qurl))) - (define-method (delete (qurl )) + (define-method (delete-pointer (qurl )) (dos_qurl_delete (ptr qurl))) - (define-class () - ((ptr accessor: ptr))) - (define (new-QPixmap) - (make 'ptr (dos_qpixmap_create))) + (define-class ()) + (define-method (initialize-instance (qpx )) + (set! (slot-value qpx 'ptr) (dos_qpixmap_create)) + (call-next-method)) (define (new-QPixmap width height) (make 'ptr (dos_qpixmap_create_width_and_height width height))) (define-method (copy (qpix )) @@ -116,19 +220,19 @@ (dos_qpixmap_assign (ptr qpix) (ptr other))) (define-method (is-null? (qpix )) (dos_qpixmap_isNull (ptr qpix))) - (define-method (delete (qpix )) + (define-method (delete-pointer (qpix )) (dos_qpixmap_delete (ptr qpix))) - (define-class () - ((ptr accessor: ptr))) + (define-class ()) (define-method (new-QQuickImageProvider callback) (make 'ptr (dos_qquickimageprovider_create callback))) - (define-method (delete (qip )) + (define-method (delete-pointer (qip )) (dos_qquickimageprovider_delete (ptr qip))) (define-class ()) - (define (new-QQmlApplicationEngine) - (make 'ptr (dos_qqmlapplicationengine_create))) + (define-method (initialize-instance (qae )) + (set! (slot-value qae 'ptr) (dos_qqmlapplicationengine_create)) + (call-next-method)) (define-method (load (appengine ) (filePath )) (dos_qqmlapplicationengine_load (ptr appengine) filePath)) (define-method (load-url (appengine ) (qurl )) @@ -141,18 +245,13 @@ (make 'ptr (dos_qqmlapplicationengine_context (ptr appengine)))) (define-method (add-image-provider (appengine ) (provider-id ) (provider )) (dos_qqmlapplicationengine_addImageProvider (ptr appengine) provider-id (ptr provider))) - (define-method (delete (appengine )) + (define-method (delete-pointer (appengine )) (dos_qqmlapplicationengine_delete (ptr appengine))) - (define-class ()) - (define (qquick-view-resize-mode value) - (case value - ((size-view-to-root-object:) (make 'value 0)) - ((size-root-object-to-view:) (make 'value 1)))) - (define-class ()) - (define (new-QQuickView) - (make 'ptr (dos_qquickview_create))) + (define-method (initialize-instance (qqv )) + (set! (slot-value qqv 'ptr) (dos_qquickview_create)) + (call-next-method)) (define-method (show (qqv )) (dos_qquickview_show (ptr qqv))) (define-method (source (qqv )) @@ -162,90 +261,55 @@ (define-method (set-source (qqv ) (filename )) (dos_qquickview_set_source (ptr qqv) filename)) (define-method (set-resize-mode (qqv ) (mode )) - (dos_qquickview_set_resize_mode (ptr qqv) (value mode))) + (dos_qquickview_set_resize_mode (ptr qqv) (val mode))) (define-method (root-context (qqv )) (make 'ptr (dos_qquickview_rootContext (ptr qqv)))) - (define-method (delete (qqv )) + (define-method (delete-pointer (qqv )) (dos_qquickview_delete (ptr qqv))) - (define-class () - ((ptr accessor: ptr))) - (define-method (initialize-instance (qv )) - (call-next-method) - (set! (ptr qv) (dos_qvariant_create))) - (define-method (qvariant (value )) - (make 'ptr (dos_qvariant_create_int value))) - (define-method (qvariant (value )) - (make 'ptr (dos_qvariant_create_bool value))) - (define-method (qvariant (value )) - (make 'ptr (dos_qvariant_create_string value))) - (define-method (qvariant (value )) - (make 'ptr (dos_qvariant_create_qobject (ptr value)))) - (define-method (qvariant (value )) - (make 'ptr (dos_qvariant_create_float value))) - (define-method (set (qv ) (value )) - (dos_qvariant_setInt (ptr qv) value)) - (define-method (set (qv ) (value )) - (dos_qvariant_setBool (ptr qv) value)) - (define-method (set (qv ) (value )) - (dos_qvariant_setFloat (ptr qv) value)) - (define-method (set (qv ) (value )) - (dos_qvariant_setString (ptr qv) value)) - (define-method (set (qv ) (value )) - (dos_qvariant_setQObject (ptr qv) (ptr value))) - (define-method (to (qv ) (target )) - (case target - ((integer:) (dos_qvariant_toInt (ptr qv))) - ((boolean:) (dos_qvariant_toBool (ptr qv))) - ((string:) (dos_qvariant_toString (ptr qv))) - ((flonum:) (dos_qvariant_toFloat (ptr qv))) - ((qobject:) (dos_qvariant_toQObject (ptr qv))))) - (define-method (is-null? (qv )) - (dos_qvariant_isnull (ptr qv))) - (define-method (assign (qv ) (other )) - (dos_qvariant_assign (ptr qv) (ptr other))) - (define-method (copy (qv )) - (make 'ptr (dos_qvariant_create_qvariant (ptr qv)))) - (define-method (delete (qv )) - (dos_qvariant_delete (ptr qv))) - - (define-class () - ((ptr accessor: ptr))) - (define (new-QMetaObject superclass, classname, signal-definitions, slot-definitions, property-definitions) + (define-class ()) + (define (new-QMetaObject superclass classname signal-definitions slot-definitions property-definitions) (make 'ptr (dos_qmetaobject_create (ptr superclass) classname signal-definitions slot-definitions property-definitions))) (define-method (invoke-method (qmo ) (callback ) (data ) (connection-type )) - (dos_qmetaobject_invoke_method (ptr qmo) callback data (value connection-type))) - (define-method (delete (qmo )) + (dos_qmetaobject_invoke_method (ptr qmo) callback data (val connection-type))) + (define-method (delete-pointer (qmo )) (dos_qmetaobject_delete (ptr qmo))) - (define-class ()) - (define (qitem-data-role value) - (case value - ((display:) (make 'value 0)) - ((decoration:) (make 'value 1)) - ((edit:) (make 'value 2)) - ((tool-tip:) (make 'value 3)) - ((status-tip:) (make 'value 4)) - ((whats-this:) (make 'value 5)) - ((font:) (make 'value 6)) - ((text-alignment:) (make 'value 7)) - ((background:) (make 'value 8)) - ((foreground:) (make 'value 9)) - ((check-state:) (make 'value 10)) - ((accessible-text:) (make 'value 11)) - ((accessible-description:) (make 'value 12)) - ((size-hint:) (make 'value 13)) - ((initial-sort-order:) (make 'value 14)))) + (define-class ()) + (define-method (initialize-instance (qmi )) + (set! (ptr qmi) (dos_qmodelindex_create)) + (call-next-method)) + (define-method (copy (qmi ) (other )) + (make 'ptr (dos_qmodelindex_create_qmodelindex (ptr qmi) (ptr other)))) + (define-method (row (qmi )) + (dos_qmodelindex_row (ptr qmi))) + (define-method (column (qmi )) + (dos_qmodelindex_column (ptr qmi))) + (define-method (is-valid? (qmi )) + (dos_qmodelindex_isValid (ptr qmi))) + (define-method (data (qmi ) (role )) + (dos_qmodelindex_data (ptr qmi) (val role))) + (define-method (parent (qmi )) + (make 'ptr (dos_qmodelindex_parent (ptr qmi)))) + (define-method (child (qmi ) (row ) (column )) + (make 'ptr (dos_qmodelindex_child (ptr qmi) row column))) + (define-method (sibling (qmi ) (row ) (column )) + (make 'ptr (dos_qmodelindex_sibling (ptr qmi) row column))) + (define-method (assign (qmi ) (other )) + (dos_qmodelindex_assign (ptr qmi) (ptr other))) + (define-method (delete-pointer (qmi )) + (dos_qmodelindex_delete (ptr qmi))) (define-class ()) (define (new-QAbstractItemModel callback meta-object dcallback callbacks) (dos_qabstractitemmodel_create callback (ptr meta-object) dcallback (ptr callbacks))) (define-method (set-data (qaim ) (qmi ) (qv ) (role )) - (dos_qabstractitemmodel_setData (ptr qaim) (ptr qmi) (ptr qv) (value role))) + (dos_qabstractitemmodel_setData (ptr qaim) (ptr qmi) (ptr qv) (val role))) (define-method (flags (qaim ) (qmi )) (dos_qabstractitemmodel_flags (ptr qaim) (ptr qmi))) - (define-method (header-data)) + (define-method (header-data (qaim ) (section ) (orientation ) (role )) + (dos_qabstractitemmodel_headerData (ptr qaim) section (val orientation) role)) (define-class ()) (define (new-QAbstractListModel callback qalm dcallback callbacks) diff --git a/qml.egg b/qml.egg index df0dd28..ca1d2c3 100644 --- a/qml.egg +++ b/qml.egg @@ -3,7 +3,7 @@ (synopsis "A Chicken wrapper for DOtherSide") (category ui) (license "LGPLv3") - (dependencies coops coops-utils foreigners utf8) + (dependencies coops coops-utils foreigners utf8 srfi-69) (foreign-dependencies Qt5Core Qt5Widgets Qt5Gui @@ -57,7 +57,7 @@ "-L" "-lQt5Network" "-L" "-lQt5Test" "-L" "-lQt5QuickTest" - "-L" "-lOpenGL")))) - ;;(extension qml.core - ;; (component-dependencies qml.lowlevel)) + "-L" "-lOpenGL")) + (extension qml.core + (component-dependencies qml.lowlevel)))) diff --git a/qml.lowlevel.scm b/qml.lowlevel.scm index 6c3ba59..e7a010f 100644 --- a/qml.lowlevel.scm +++ b/qml.lowlevel.scm @@ -1,3 +1,4 @@ +;; -*- geiser-scheme: chicken -*- (module (qml lowlevel) * (import (scheme base)) @@ -109,17 +110,17 @@ (define-foreign-type DosQAbstractItemModelCallbacks (struct "DosQAbstractItemModelCallbacks")) (define-foreign-type DosQEventLoopProcessEventFlag (enum "DosQEventLoopProcessEventFlag")) - (define DosQEventLoopProcessEventFlagProcessAllEvents (foreign-value "0x00" byte)) - (define DosQEventLoopProcessEventFlagExcludeUserInputEvents (foreign-value "0x01" byte)) - (define DosQEventLoopProcessEventFlagProcessExcludeSocketNotifiers (foreign-value "0x02" byte)) - (define DosQEventLoopProcessEventFlagProcessAllEventsWaitForMoreEvents (foreign-value "0x03" byte)) + (define DosQEventLoopProcessEventFlagProcessAllEvents #x00) + (define DosQEventLoopProcessEventFlagExcludeUserInputEvents #x01) + (define DosQEventLoopProcessEventFlagProcessExcludeSocketNotifiers #x02) + (define DosQEventLoopProcessEventFlagProcessAllEventsWaitForMoreEvents #x03) (define-foreign-type DosQtConnectionType (enum "DosQtConnectionType")) (define DosQtConnectionTypeAutoConnection 0) (define DosQtConnectionTypeDirectConnection 1) (define DosQtConnectionTypeQueuedConnection 2) (define DosQtConnectionTypeBlockingConnection 3) - (define DosQtConnectionTypeUniqueConnection (foreign-value "0x80" byte)) + (define DosQtConnectionTypeUniqueConnection #x80) ;; Functions ;; QCoreApplication