Thu Jan 7 22:03:05 CET 2010 Tobias Rautenkranz * modular smoke & cl-smoke prefix. Wed Jul 8 16:59:00 CEST 2009 Tobias Rautenkranz * Set package when starting event loop in background. Wed Jul 1 13:05:25 CEST 2009 Tobias Rautenkranz * Use new qt:with-app. Sun Jun 7 09:47:13 CEST 2009 Tobias Rautenkranz * #'END-EVENT-LOOP & cleanup Sat Jun 6 17:07:40 CEST 2009 Tobias Rautenkranz * test event loop in background Fri Jun 5 09:50:38 CEST 2009 Tobias Rautenkranz * Set *package* from #'QT-EVAL. Thu Jun 4 22:48:44 CEST 2009 Tobias Rautenkranz * initial commit diff -rN -u old-repl/cl-smoke.repl.asd new-repl/cl-smoke.repl.asd --- old-repl/cl-smoke.repl.asd 1970-01-01 01:00:00.000000000 +0100 +++ new-repl/cl-smoke.repl.asd 2014-11-17 12:27:46.000000000 +0100 @@ -0,0 +1,20 @@ +(asdf:defsystem :cl-smoke.repl + :name :cl-smoke.repl + :version (0 0 1) + :author "Tobias Rautenkranz" + :license "GPL with linking exception" + :description "REPL support for cl-smoke." + :depends-on (:cl-smoke.qt.gui) + :components + ((:module "src" + :components + ((:file "package") (:file "repl" :depends-on ("package")) + (:file "locate-widget" :depends-on ("package")) + (:file "get-widget" :depends-on ("package")))))) + +(defmethod operation-done-p ((o test-op) (c (eql (find-system :cl-smoke.repl)))) + nil) + +(defmethod perform ((o test-op) (c (eql (find-system :cl-smoke.repl)))) + (operate 'asdf:load-op :cl-smoke.repl-tests) + (operate 'asdf:test-op :cl-smoke.repl-tests)) diff -rN -u old-repl/src/get-widget.lisp new-repl/src/get-widget.lisp --- old-repl/src/get-widget.lisp 1970-01-01 01:00:00.000000000 +0100 +++ new-repl/src/get-widget.lisp 2014-11-17 12:27:46.000000000 +0100 @@ -0,0 +1,41 @@ +(in-package :cl-smoke.repl) + +(defclass get-widget (qt:dialog) + ((widget :initform nil + :accessor widget) + (label :initform (make-instance 'qt:label) + :reader label)) + (:metaclass cxx:class)) + +(defmethod initialize-instance :after ((get-widget get-widget) &key) + (let ((layout (make-instance 'qt:vbox-layout)) + (get-button (make-instance 'qt:push-button :args '("Get")))) + (cxx:add-widget layout (label get-widget)) + (cxx:add-widget layout get-button) + (cxx:set-checkable get-button t) + (qt:connect (qt:get-signal get-button "clicked()") + #'(lambda () + (cxx:grab-mouse get-widget) + (setf (cxx:text get-button) + "Click on a widget."))) + (cxx:set-layout get-widget layout)) + (cxx:set-window-title get-widget "Get Widget") + (cxx:set-mouse-tracking get-widget t)) + +(defmethod cxx:mouse-press-event ((get-widget get-widget) event) + (cxx:release-mouse get-widget) + (setf (widget get-widget) (qt:application.widget-at (cxx:global-pos event))) + (cxx:done get-widget 0)) + + +(defmethod cxx:mouse-move-event ((get-widget get-widget) event) + (setf (cxx:text (label get-widget)) + (format nil "~A~%" (qt:application.widget-at (cxx:global-pos event))))) + + +(defun get-widget () + "Returns the widget selected with the mouse." + (let ((get-widget (make-instance 'get-widget))) + (unwind-protect (cxx:exec get-widget) ;; run the dialog + (cxx:release-mouse get-widget)) + (widget get-widget))) diff -rN -u old-repl/src/locate-widget.lisp new-repl/src/locate-widget.lisp --- old-repl/src/locate-widget.lisp 1970-01-01 01:00:00.000000000 +0100 +++ new-repl/src/locate-widget.lisp 2014-11-17 12:27:46.000000000 +0100 @@ -0,0 +1,51 @@ +(in-package :cl-smoke.repl) + +(defclass highlight-widget (qt:widget) + () + (:metaclass cxx:class) + (:documentation "A red border.")) + +(defun make-highligh-mask (rectangle &optional (border 10)) + (let* ((border/2 (/ border 2)) + (mask (make-instance 'qt:region + :args (list (cxx:adjusted rectangle + (- border/2) (- border/2) + border/2 border/2)))) + (inner (cxx:adjusted rectangle border/2 border/2 + (- border/2) (- border/2)))) + (cxx:subtracted mask inner))) + +(defmethod initialize-instance :after ((widget highlight-widget) &key) + (cxx:set-window-flags widget (enum-logior + qt:+window-stays-on-top-hint+ + qt:+frameless-window-hint+ + qt:+x11bypass-window-manager-hint+)) + (cxx:set-palette widget + (make-instance 'qt:palette :args '("Red"))) + (cxx:set-auto-fill-background widget t)) + +(defun blink-and-follow (widget follow times &optional (intervall 0.5)) + (let ((timer (make-instance 'qt:timer :args (list widget)))) + (qt:connect (qt:get-signal timer "timeout()") + #'(lambda () + (when (<= times 1) + (cxx:stop timer)) + ;; Track the follow widgets geometry + (cxx:set-geometry widget (cxx:geometry follow)) + (cxx:set-mask widget + (make-highligh-mask (cxx:rect follow))) + + (if (evenp times) + (cxx:show widget) + (cxx:hide widget)) + (decf times))) + (cxx:start timer (floor (* intervall 1000))))) + +(defun locate-widget (widget) + "Shows the location of WIDGET on the screen." + (unless (cxx:is-visible widget) + (cerror "show the widget" "The widget ~A is not visible." widget) + (cxx:show widget)) + (cxx:raise widget) ;; Focus stealing prevention might intercept this. + (let ((highlight (make-instance 'highlight-widget))) + (blink-and-follow highlight widget 5))) diff -rN -u old-repl/src/package.lisp new-repl/src/package.lisp --- old-repl/src/package.lisp 1970-01-01 01:00:00.000000000 +0100 +++ new-repl/src/package.lisp 2014-11-17 12:27:46.000000000 +0100 @@ -0,0 +1,13 @@ +(eval-when (:load-toplevel :compile-toplevel) + (unless (member :slime *features*) + (when (find-package :swank) + (push :slime *features*)))) + +(defpackage :cl-smoke.repl + (:use :cl :cxx-support) + (:export #:start-event-loop-in-background + #:end-event-loop + #+slime #:start-event-loop-in-repl + #:get-widget + #:locate-widget)) + diff -rN -u old-repl/src/repl.lisp new-repl/src/repl.lisp --- old-repl/src/repl.lisp 1970-01-01 01:00:00.000000000 +0100 +++ new-repl/src/repl.lisp 2014-11-17 12:27:46.000000000 +0100 @@ -0,0 +1,108 @@ +(in-package :cl-smoke.repl) + +(defvar *qt-eval*) + +(defclass qt-eval (qt:object) + ((eval-slot :initform (qt:make-slot + #'(lambda (form) + (setf (result *qt-eval*) (multiple-value-list (eval form)) + (new-package *qt-eval*) *package*)) + '(t)) + :reader eval-slot) + (eval-signal :initform (qt:make-signal t) + :reader eval-signal + :documentation "Send an form to evaluate.") + (result :accessor result) + (package :accessor new-package :initarg :package)) + (:metaclass cxx:class)) + +(defmethod initialize-instance :after ((qt-eval qt-eval) &key &allow-other-keys) + (qt:connect (eval-signal qt-eval) (eval-slot qt-eval) qt:+blocking-queued-connection+)) + +(defun qt-eval (form) + "Returns the result of FORM evaluated in the event loop thread." + (funcall (eval-signal *qt-eval*) form) + (setf *package* (new-package *qt-eval*)) + (values-list (result *qt-eval*))) + +(let ((eval-region-orig)) + (defun end-event-loop () + #+slime + (progn + (assert eval-region-orig) + (setf (fdefinition 'swank::eval-region) + eval-region-orig) + (setf eval-region-orig nil)) + (cxx:quit (qt:app))) + (defun start-event-loop-in-background () + "Starts the QApplication event loop in a new thread and +sends the forms entered at the REPL to this thread to be evaluated." + ;; Like eval-region of Slimes swank.lisp + #+slime + (progn + (assert (null eval-region-orig)) + (setf eval-region-orig + #'swank::eval-region) + (setf (fdefinition 'swank::eval-region) + #'(lambda (string) + (with-input-from-string (stream string) + (let (- values) + (loop + (let ((form (read stream nil stream))) + (when (eq form stream) + (fresh-line) + (finish-output) + (return (values values -))) + (setq - form) + (setq values (multiple-value-list (qt-eval form))) + (finish-output)))))))) + (let ((standard-input *standard-input*) + (standard-output *standard-output*) + (debug-io *debug-io*) + (trace-output *trace-output*) + (error-output *error-output*) + (query-io *query-io*) + (terminal-io *terminal-io*) + (ready-lock (bt:make-lock)) + (ready (bt:make-condition-variable))) + (bt:make-thread #'(lambda () + #+slime + (setf *standard-input* standard-input + *standard-output* standard-output + *debug-io* debug-io + *trace-output* trace-output + *error-output* error-output + *query-io* query-io + *terminal-io* terminal-io) + (qt:with-app () + (qt:application.set-quit-on-last-window-closed nil) + (setf *qt-eval* (make-instance 'qt-eval :package *package*)) + (qt:do-delayed-initialize + (bt:condition-notify ready)) + (qt:connect (qt:get-signal (qt:app) + "aboutToQuit()") + #'(lambda () + (setf *qt-eval* nil))) + (qt:exec))) + :name "Qt Event Loop") + (bt:with-lock-held (ready-lock) + (bt:condition-wait ready ready-lock))))) + +#+slime +(defun start-event-loop-in-repl () + "Start the QApplication event loop in the current REPL thread. +When idle the event loop updates the REPL. + +While the idea is fine, it is a hack and the displaying of the argument list +in SLIME is fluky." + (funcall swank::*send-repl-results-function* '(nil)) + (qt:with-app () + (qt:application.set-quit-on-last-window-closed nil) + (let ((idle (make-instance 'qt:timer))) + (qt:connect (qt:get-signal idle "timeout()") + #'(lambda () + (swank::process-requests t) ;; it's a wonder this even works! + (sb-impl::serve-event 0.1))) + (cxx:start idle) + (qt:exec) + (format *debug-io* "New-repl end~%")))) diff -rN -u old-repl/test.lisp new-repl/test.lisp --- old-repl/test.lisp 1970-01-01 01:00:00.000000000 +0100 +++ new-repl/test.lisp 2014-11-17 12:27:46.000000000 +0100 @@ -0,0 +1,26 @@ +;;; sbcl < test.lisp +;;; +;;; somehow #'LOADing the test file hangs WITH-APP!? +;;; Thus the pipe +;;; + +(require :cl-smoke.repl) + +(in-package :cl-smoke.repl) + +(defun test-event-loop-in-background () + (start-event-loop-in-background) + (qt-eval '(defvar *w* (make-instance 'qt:push-button))) + (qt-eval '(cxx:show *w*)) + (qt-eval '(setf (cxx:text *w*) "Hello World!")) + (qt-eval '(assert (string= "Hello World!" (cxx:text *w*)))) + (qt-eval '(cxx:adjust-size *w*)) + (qt-eval '(in-package :smoke)) + (qt-eval '(assert (eql (find-package :smoke) *package*))) + (qt-eval '(end-event-loop))) + +(test-event-loop-in-background) + +(print "success") + +(sb-ext:quit) diff -rN -u old-repl/test.sh new-repl/test.sh --- old-repl/test.sh 1970-01-01 01:00:00.000000000 +0100 +++ new-repl/test.sh 2014-11-17 12:27:46.000000000 +0100 @@ -0,0 +1,3 @@ +#!/bin/sh +sbcl < test.lisp +exit $?