Update of /project/beirc/cvsroot/beirc In directory clnet:/tmp/cvs-serv18310

Modified Files: application.lisp presentations.lisp Log Message: Catch bad input on the interactor and present it in a way that allows re-editing.

Works in mcclim only, sorry.

--- /project/beirc/cvsroot/beirc/application.lisp 2006/04/20 02:23:56 1.78 +++ /project/beirc/cvsroot/beirc/application.lisp 2006/04/20 06:39:27 1.79 @@ -444,6 +444,11 @@ (define-window-switcher com-window-next (:next :control) 1 (constantly t)) (define-window-switcher com-window-previous (:prior :control) -1 (constantly t))))

+(define-beirc-command (com-insert-input :name t) ((input 'bad-input)) + (setf (incomplete-input (current-receiver *application-frame*)) + (concatenate 'string (incomplete-input (current-receiver *application-frame*)) + input))) + (define-beirc-command (com-close :name t) ((receivers '(sequence receiver) :prompt "tab" :default (list (current-receiver *application-frame*)))) (dolist (receiver receivers) (let* ((connection (connection receiver)) @@ -703,6 +708,16 @@ (beep)) #+sbcl (simple-error (e) (format t "~a" e))))

+(define-presentation-to-command-translator incomplete-input-to-input-translator + (bad-input com-insert-input beirc + :menu nil + :gesture :select + :documentation "Append this to the input line" + :pointer-documentation "Append this to the input line" + :priority 10) + (object) + (list object)) + (define-presentation-to-command-translator nickname-to-ignore-translator (nickname com-ignore beirc :menu t @@ -969,7 +984,8 @@ (with-output-to-string (s) (loop for elt across buffer if (characterp elt) - do (write-char elt s))))))) + do (write-char elt s)))) + (incomplete-input (current-receiver frame)))))

(define-condition invoked-command-by-clicking () () @@ -1013,48 +1029,69 @@ (call-next-method))

(defmethod read-frame-command ((frame beirc) &key (stream *standard-input*)) - (unwind-protect - (clim:with-input-editing (stream) - (when (and (current-receiver frame) (incomplete-input (current-receiver frame))) - (replace-input stream (incomplete-input (current-receiver frame)) :rescan t)) - (with-input-context ('command) (object) - (with-command-table-keystrokes (*accelerator-gestures* (frame-command-table frame)) - (catch 'keystroke-command - (let ((force-restore-input-state nil)) - (labels ((reset-saved-input () - (when (current-receiver frame) - (setf (incomplete-input (current-receiver frame)) "")))) - (handler-bind ((accelerator-gesture - (lambda (gesture) - (save-input-line stream frame) - (throw 'keystroke-command (lookup-keystroke-command-item - (accelerator-gesture-event gesture) - (frame-command-table frame))))) - (abort-gesture - (lambda (gesture) - (declare (ignore gesture)) - (reset-saved-input) - (setf force-restore-input-state nil))) - (invoked-command-by-clicking - (lambda (cond) - (declare (ignore cond)) - (save-input-line stream frame) - (setf force-restore-input-state t) - (invoke-restart 'acknowledged)))) - (let ((c (clim:read-gesture :stream stream :peek-p t))) - (multiple-value-prog1 - (cond ((eql c #/) - (clim:read-gesture :stream stream) - (accept 'command :stream stream :prompt nil)) - (t - (list 'com-say (accept 'mumble :history 'mumble :prompt nil :stream stream)))) - (if force-restore-input-state - (setf force-restore-input-state nil) - (reset-saved-input))))))))) - (command - (save-input-line stream frame) - object))) - (window-clear stream))) + (let ((bad-input nil)) + (unwind-protect + (clim:with-input-editing (stream) + (when (and (current-receiver frame) (incomplete-input (current-receiver frame))) + (replace-input stream (incomplete-input (current-receiver frame)) :rescan t)) + (with-input-context ('command) (object) + (with-command-table-keystrokes (*accelerator-gestures* (frame-command-table frame)) + (catch 'keystroke-command + (let ((force-restore-input-state nil)) + (labels ((reset-saved-input () + (when (current-receiver frame) + (setf (incomplete-input (current-receiver frame)) "")))) + (handler-bind ((accelerator-gesture + (lambda (gesture) + (save-input-line stream frame) + (throw 'keystroke-command (lookup-keystroke-command-item + (accelerator-gesture-event gesture) + (frame-command-table frame))))) + (abort-gesture + (lambda (gesture) + (declare (ignore gesture)) + (reset-saved-input) + (setf force-restore-input-state nil))) + (invoked-command-by-clicking + (lambda (cond) + (declare (ignore cond)) + (save-input-line stream frame) + (setf force-restore-input-state t) + (invoke-restart 'acknowledged)))) + (let ((c (clim:read-gesture :stream stream :peek-p t))) + (multiple-value-prog1 + (cond ((eql c #/) + (handler-case + (progn + (clim:read-gesture :stream stream) + (accept 'command :stream stream :prompt nil)) + (simple-completion-error (c) + #+mcclim + (let ((preliminary-line (save-input-line stream frame))) + (setf (incomplete-input (current-receiver frame)) + (subseq preliminary-line 0 + (search (climi::completion-error-input-so-far c) + preliminary-line)) + bad-input (subseq preliminary-line + (search (climi::completion-error-input-so-far c) + preliminary-line)) + force-restore-input-state t)) + (beep) + nil))) + (t + (list 'com-say (accept 'mumble :history 'mumble :prompt nil :stream stream)))) + (if force-restore-input-state + (setf force-restore-input-state nil) + (reset-saved-input))))))))) + (command + (save-input-line stream frame) + object))) + (window-clear stream) + (when bad-input + (format stream "Bad input "") + (with-drawing-options (stream :ink +red3+) + (present bad-input 'bad-input :stream stream)) + (format stream "".")))))

(defun irc-event-loop (frame connection) (let ((*application-frame* frame)) --- /project/beirc/cvsroot/beirc/presentations.lisp 2006/03/22 00:31:14 1.13 +++ /project/beirc/cvsroot/beirc/presentations.lisp 2006/04/20 06:39:27 1.14 @@ -8,6 +8,8 @@ (define-presentation-type channel () :inherit-from 'string) (define-presentation-type hostmask () :inherit-from 'string)

+(define-presentation-type bad-input () :inherit-from 'string) + (defun hash-alist (hashtable &aux res) (maphash (lambda (k v) (push (cons k v) res)) hashtable) res)