Update of /project/mcclim/cvsroot/mcclim/Apps/Listener In directory clnet:/tmp/cvs-serv6416

Modified Files: dev-commands.lisp listener.lisp Log Message: Replace HACKISH-PRESENT with a view class mixin.

--- /project/mcclim/cvsroot/mcclim/Apps/Listener/dev-commands.lisp 2006/04/10 21:24:53 1.35 +++ /project/mcclim/cvsroot/mcclim/Apps/Listener/dev-commands.lisp 2006/11/17 09:51:18 1.36 @@ -602,13 +602,13 @@ (with-ink (readers) (if readers (dolist (reader readers) - (hackish-present reader) + (present reader (presentation-type-of reader) :single-box t) (terpri)) (note "No readers~%"))) (with-ink (writers) (if writers (dolist (writer writers) - (hackish-present writer) + (present writer (presentation-type-of writer) :single-box t) (terpri)) (note "No writers"))))))

@@ -1437,18 +1437,13 @@

;;; Eval

-(defun hackish-present (object) - "Hack of the day.. let McCLIM determine presentation type to use, except for lists, because the list presentation method is inappropriate for lisp return values." - (typecase object - (sequence (present object 'expression)) - (t (present object)))) - (defun display-evalues (values) (with-drawing-options (t :ink +olivedrab+) (cond ((null values) (format t "No values.~%")) ((= 1 (length values)) - (hackish-present (first values)) + (present (first values) (presentation-type-of (first values)) + :single-box t) (fresh-line)) (t (do ((i 0 (1+ i)) (item values (rest item))) @@ -1456,7 +1451,8 @@ (with-drawing-options (t :ink +limegreen+) (with-text-style (t (make-text-style nil :italic :small)) (format t "~A " i))) - (hackish-present (first item)) + (present (first item) (presentation-type-of (first item)) + :single-box t) (fresh-line))))))

(defun shuffle-specials (form values) --- /project/mcclim/cvsroot/mcclim/Apps/Listener/listener.lisp 2006/05/10 11:19:33 1.26 +++ /project/mcclim/cvsroot/mcclim/Apps/Listener/listener.lisp 2006/11/17 09:51:18 1.27 @@ -150,7 +150,41 @@ (lambda () (funcall *listener-initial-function*) (fresh-line))))) - + +;;; Listener view +;;; +;;; FIXME: this TEXTUAL-VIEW thing is a lie: we can draw graphics. +;;; However, all the various presentation methods around the world are +;;; specialized on textual view, and it sucks to have to reimplement +;;; them all. +(defclass listener-view (textual-view) ()) + +(defclass listener-pointer-documentation-view + (listener-view pointer-documentation-view) + ()) + +(defparameter +listener-view+ (make-instance 'listener-view)) +(defparameter +listener-pointer-documentation-view+ + (make-instance 'listener-pointer-documentation-view)) + +(define-presentation-method present :around + ((object sequence) (type sequence) stream (view listener-view) + &key acceptably for-context-type) + (present object 'expression :stream stream :view view + :acceptably acceptably :for-context-type for-context-type)) + +(define-presentation-method accept :around + ((type sequence) stream (view listener-view) &key default default-type) + (let* ((token (read-token stream)) + (result (handler-case (read-from-string token) + (error (c) + (declare (ignore c)) + (simple-parse-error + "Error parsing ~S for presentation type ~S" + token type))))) + (if (presentation-typep result type) + (values result type) + (input-not-of-required-type result type))))

;;; Listener application frame (define-application-frame listener (standard-application-frame @@ -213,7 +247,11 @@ (*read-default-float-format* *read-default-float-format*) (*read-eval* *read-eval*) (*read-suppress* *read-suppress*) - (*readtable* *readtable*)) + (*readtable* *readtable*)) + (setf (stream-default-view (get-frame-pane frame 'interactor)) + +listener-view+) + (setf (stream-default-view (get-frame-pane frame 'doc)) + +listener-pointer-documentation-view+) (loop while (catch 'return-to-listener (restart-case (call-next-method) @@ -258,43 +296,52 @@ (let* ((command-table (find-command-table 'listener)) (*accelerator-gestures* (climi::compute-inherited-keystrokes command-table)) object type) - (handler-case - ;; Body - (with-input-editing (stream :input-sensitizer - (lambda (stream cont) - (if type - (with-output-as-presentation - (stream object type) - (funcall cont)) - (funcall cont)))) - (let ((c (read-gesture :stream stream :peek-p t))) - (setf object - (if (member c *form-opening-characters*) - (prog2 - (when (char= c #,) - (read-gesture :stream stream)) ; lispm behavior - #| ---> |# (list 'com-eval (accept 'form :stream stream :prompt nil)) - (setf type 'command #|'form|# )) ; FIXME? - (prog1 - (accept '(command :command-table listener) :stream stream - :prompt nil) - (setf type 'command)))))) - ;; Handlers - ((or simple-parse-error input-not-of-required-type) (c) - (beep) - (fresh-line *query-io*) - (princ c *query-io*) - (terpri *query-io*) - nil) - (accelerator-gesture (c) - (let ((command (lookup-keystroke-command-item (accelerator-gesture-event c) - command-table))) - (setf ;type 'command - object (if (partial-command-p command) - (funcall *partial-command-parser* - command-table stream command - (position *unsupplied-argument-marker* command)) - command))))) + (flet ((sensitizer (stream cont) + (case type + ((command) (with-output-as-presentation + (stream object type :single-box t) + (funcall cont))) + ((form) (with-output-as-presentation + (stream object 'command :single-box t) + (with-output-as-presentation + (stream (cadr object) + (presentation-type-of (cadr object)) + :single-box t) + (funcall cont)))) + (t (funcall cont))))) + (handler-case + ;; Body + (with-input-editing + (stream :input-sensitizer #'sensitizer) + (let ((c (read-gesture :stream stream :peek-p t))) + (setf object + (if (member c *form-opening-characters*) + (prog2 + (when (char= c #,) + ;; lispm behavior + (read-gesture :stream stream)) + (list 'com-eval (accept 'form :stream stream :prompt nil)) + (setf type 'form)) + (prog1 + (accept '(command :command-table listener) :stream stream + :prompt nil) + (setf type 'command)))))) + ;; Handlers + ((or simple-parse-error input-not-of-required-type) (c) + (beep) + (fresh-line *query-io*) + (princ c *query-io*) + (terpri *query-io*) + nil) + (accelerator-gesture (c) + (let ((command (lookup-keystroke-command-item (accelerator-gesture-event c) + command-table))) + (setf ;type 'command + object (if (partial-command-p command) + (funcall *partial-command-parser* + command-table stream command + (position *unsupplied-argument-marker* command)) + command)))))) object)))

(defmethod read-frame-command :around ((frame listener) @@ -303,14 +350,14 @@ and whatever else need be done." (multiple-value-bind (x y) (stream-cursor-position stream) (with-input-context ('command) (object object-type) - (call-next-method) - (command - ;; Kludge the cursor position - Goatee will have moved it all around - (setf (stream-cursor-position stream) (values x y)) - (present object object-type - :view (stream-default-view stream) - :stream stream) - object)))) + (call-next-method) + (command + ;; Kludge the cursor position - Goatee will have moved it all around + (setf (stream-cursor-position stream) (values x y)) + (present object object-type + :view (stream-default-view stream) + :stream stream :single-box t) + object))))

(defun print-listener-prompt (stream frame) (declare (ignore frame)) @@ -328,14 +375,14 @@ (process-name "Listener") (eval nil)) (flet ((run () - (run-frame-top-level - (make-application-frame 'listener - :width width - :height height - :system-command-reader system-command-reader) - :listener-funcall (cond ((null eval) nil) - ((functionp eval) eval) - (t (lambda () (eval eval))))))) + (let ((frame (make-application-frame + 'listener + :width width :height height + :system-command-reader system-command-reader))) + (run-frame-top-level + frame :listener-funcall (cond ((null eval) nil) + ((functionp eval) eval) + (t (lambda () (eval eval)))))))) (if new-process (clim-sys:make-process #'run :name process-name) (run))))