Thu Jun 4 22:48:44 CEST 2009 Tobias Rautenkranz * initial commit diff -rN -u old-repl/repl.mbd new-repl/repl.mbd --- old-repl/repl.mbd 1970-01-01 01:00:00.000000000 +0100 +++ new-repl/repl.mbd 2014-10-30 08:04:09.000000000 +0100 @@ -0,0 +1,17 @@ +;;;; -*- 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)) 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-10-30 08:04:09.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-10-30 08:04:09.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-10-30 08:04:09.000000000 +0100 @@ -0,0 +1,7 @@ +(defpackage :cl-smoke.repl + (:use :cl :cxx-support) + (:export #:start-event-loop-in-background + #: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-10-30 08:04:09.000000000 +0100 @@ -0,0 +1,101 @@ +(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~%"))))