Thu Jan 7 22:03:05 CET 2010 Tobias Rautenkranz <tobias@rautenkranz.ch>
* modular smoke & cl-smoke prefix.
addfile ./cl-smoke.repl.asd
hunk ./cl-smoke.repl.asd 1
+(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))
hunk ./repl.mbd 1
-;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
-
-(in-package :sysdef-user)
-
-(define-system :cl-smoke.repl ()
- (:version 0 0 1)
- (:documentation "REPL support for cl-smoke.")
- (:author "Tobias Rautenkranz")
- (:license "GPL with linking exception")
- (:components
- ("src" module
- (:components
- "package"
- ("repl" (:needs "package"))
- ("locate-widget" (:needs "package"))
- ("get-widget" (:needs "package")))))
- (:needs :qt))
rmfile ./repl.mbd
hunk ./test.lisp 7
-(in-package :sysdef-user)
-
-(defun load-sysdef (pathname system)
- (load pathname)
- (setf (mb.sysdef::pathname-of (find-system system)) pathname))
-
-(defun load-sysdef-file (system-name)
- "Loads a mbd file in the current directory."
- (load-sysdef (first (directory "*.mbd"))
- system-name))
-
-(load-sysdef-file :cl-smoke.repl)
-(mb:load :cl-smoke.repl)
+(require :cl-smoke.repl)
changepref test
sh ./test.sh
sh test.sh
Wed Jul 8 16:59:00 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>
* Set package when starting event loop in background.
hunk ./src/repl.lisp 16
- (package :accessor new-package))
+ (package :accessor new-package :initarg :package))
hunk ./src/repl.lisp 79
- (setf *qt-eval* (make-instance 'qt-eval))
+ (setf *qt-eval* (make-instance 'qt-eval :package *package*))
Wed Jul 1 13:05:25 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>
* Use new qt:with-app.
hunk ./src/repl.lisp 77
- (qt:with-app
- (qt:application.set-quit-on-last-window-closed nil)
+ (qt:with-app ()
+ (qt:application.set-quit-on-last-window-closed nil)
hunk ./src/repl.lisp 81
- (bt:condition-notify ready))
+ (bt:condition-notify ready))
hunk ./src/repl.lisp 99
- (qt:with-app
- (qt:application.set-quit-on-last-window-closed nil)
+ (qt:with-app ()
+ (qt:application.set-quit-on-last-window-closed nil)
hunk ./src/repl.lisp 103
- #'(lambda ()
- (swank::process-requests t) ;; it's a wonder this even works!
- (sb-impl::serve-event 0.1)))
+ #'(lambda ()
+ (swank::process-requests t) ;; it's a wonder this even works!
+ (sb-impl::serve-event 0.1)))
Sun Jun 7 09:47:13 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>
* #'END-EVENT-LOOP & cleanup
hunk ./src/package.lisp 9
+ #:end-event-loop
hunk ./src/repl.lisp 28
-(defun end-event-loop ()
- #+slime
- (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 (eval form)))
- (finish-output)))))))
- (cxx:quit (qt:app)))
- [_$_]
-(defun start-event-loop-in-background ()
- "Starts the QApplication event loop in a new thread and
+(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
hunk ./src/repl.lisp 40
- ;; Like eval-region of Slimes swank.lisp
- #+slime
- (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))
- (qt:do-delayed-initialize [_$_]
+ ;; 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))
+ (qt:do-delayed-initialize [_$_]
hunk ./src/repl.lisp 82
- (qt:exec)))
- :name "Qt Event Loop")
- (bt:with-lock-held (ready-lock)
- (bt:condition-wait ready ready-lock))))
+ (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)))))
hunk ./src/repl.lisp 104
- ; (swank::handle-requests swank::*emacs-connection* t)
hunk ./src/repl.lisp 106
- ;(curry #'sb-impl::serve-event 0.1))
Sat Jun 6 17:07:40 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>
* test event loop in background
hunk ./src/package.lisp 1
+(eval-when (:load-toplevel :compile-toplevel)
+ (unless (member :slime *features*)
+ (when (find-package :swank)
+ (push :slime *features*))))
+
hunk ./src/package.lisp 9
- #:start-event-loop-in-repl
+ #+slime #:start-event-loop-in-repl
hunk ./src/repl.lisp 29
+ #+slime
hunk ./src/repl.lisp 49
+ #+slime
hunk ./src/repl.lisp 69
- (terminal-io *terminal-io*))
+ (terminal-io *terminal-io*)
+ (ready-lock (bt:make-lock))
+ (ready (bt:make-condition-variable)))
hunk ./src/repl.lisp 73
+ #+slime
hunk ./src/repl.lisp 84
- (format t "exec~%")
- (qt:exec)
- (format t "exec-done~%")))
- :name "Qt Event Loop")))
+ (qt:do-delayed-initialize [_$_]
+ (bt:condition-notify ready))
+ (qt:exec)))
+ :name "Qt Event Loop")
+ (bt:with-lock-held (ready-lock)
+ (bt:condition-wait ready ready-lock))))
hunk ./src/repl.lisp 91
+#+slime
addfile ./test.lisp
hunk ./test.lisp 1
+;;; sbcl < test.lisp
+;;;
+;;; somehow #'LOADing the test file hangs WITH-APP!?
+;;; Thus the pipe
+;;;
+
+(in-package :sysdef-user)
+
+(defun load-sysdef (pathname system)
+ (load pathname)
+ (setf (mb.sysdef::pathname-of (find-system system)) pathname))
+
+(defun load-sysdef-file (system-name)
+ "Loads a mbd file in the current directory."
+ (load-sysdef (first (directory "*.mbd"))
+ system-name))
+
+(load-sysdef-file :cl-smoke.repl)
+(mb:load :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)
addfile ./test.sh
hunk ./test.sh 1
+#!/bin/sh
+sbcl < test.lisp
+exit $?
changepref test
sh ./test.sh
Fri Jun 5 09:50:38 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>
* Set *package* from #'QT-EVAL.
hunk ./src/repl.lisp 5
-(defvar *result*)
-
hunk ./src/repl.lisp 8
- (setf *result*
- (multiple-value-list (eval form))))
+ (setf (result *qt-eval*) (multiple-value-list (eval form))
+ (new-package *qt-eval*) *package*))
hunk ./src/repl.lisp 14
- :documentation "Send an form to evaluate."))
+ :documentation "Send an form to evaluate.")
+ (result :accessor result)
+ (package :accessor new-package))
hunk ./src/repl.lisp 25
- (values-list *result*))
+ (setf *package* (new-package *qt-eval*))
+ (values-list (result *qt-eval*)))
Thu Jun 4 22:48:44 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>
* initial commit
addfile ./repl.mbd
hunk ./repl.mbd 1
+;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
+
+(in-package :sysdef-user)
+
+(define-system :cl-smoke.repl ()
+ (:version 0 0 1)
+ (:documentation "REPL support for cl-smoke.")
+ (:author "Tobias Rautenkranz")
+ (:license "GPL with linking exception")
+ (:components
+ ("src" module
+ (:components
+ "package"
+ ("repl" (:needs "package"))
+ ("locate-widget" (:needs "package"))
+ ("get-widget" (:needs "package")))))
+ (:needs :qt))
adddir ./src
addfile ./src/get-widget.lisp
hunk ./src/get-widget.lisp 1
+(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)))
addfile ./src/locate-widget.lisp
hunk ./src/locate-widget.lisp 1
+(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)))
addfile ./src/package.lisp
hunk ./src/package.lisp 1
+(defpackage :cl-smoke.repl
+ (:use :cl :cxx-support)
+ (:export #:start-event-loop-in-background
+ #:start-event-loop-in-repl
+ #:get-widget
+ #:locate-widget))
+
addfile ./src/repl.lisp
hunk ./src/repl.lisp 1
+(in-package :cl-smoke.repl)
+
+(defvar *qt-eval*)
+
+(defvar *result*)
+
+(defclass qt-eval (qt:object)
+ ((eval-slot :initform (qt:make-slot
+ #'(lambda (form)
+ (setf *result*
+ (multiple-value-list (eval form))))
+ '(t))
+ :reader eval-slot)
+ (eval-signal :initform (qt:make-signal t)
+ :reader eval-signal
+ :documentation "Send an form to evaluate."))
+ (: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)
+ (values-list *result*))
+
+(defun end-event-loop ()
+ (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 (eval form)))
+ (finish-output)))))))
+ (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
+ (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*))
+ (bt:make-thread #'(lambda ()
+ (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))
+ (format t "exec~%")
+ (qt:exec)
+ (format t "exec-done~%")))
+ :name "Qt Event Loop")))
+
+(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::handle-requests swank::*emacs-connection* t)
+ (swank::process-requests t) ;; it's a wonder this even works!
+ (sb-impl::serve-event 0.1)))
+ ;(curry #'sb-impl::serve-event 0.1))
+ (cxx:start idle)
+ (qt:exec)
+ (format *debug-io* "New-repl end~%"))))