Index: /branches/event-ide/ccl/cocoa-ide/cocoa-editor.lisp =================================================================== --- /branches/event-ide/ccl/cocoa-ide/cocoa-editor.lisp (revision 7918) +++ /branches/event-ide/ccl/cocoa-ide/cocoa-editor.lisp (revision 7919) @@ -1933,5 +1933,5 @@ (release-lock (hi::buffer-lock b))) -(defun invoke-modifying-buffer-storage (buffer thunk) +(defun hemlock-ext:invoke-modifying-buffer-storage (buffer thunk) (assume-cocoa-thread) (when buffer ;; nil means just get rid of any prior buffer @@ -2267,5 +2267,5 @@ (point (hi::buffer-point buffer)) (pointpos (hi:mark-absolute-position point))) - (invoke-modifying-buffer-storage + (hemlock-ext:invoke-modifying-buffer-storage buffer #'(lambda () @@ -2350,6 +2350,5 @@ (display (hemlock-buffer-string-cache (#/hemlockString textstorage))) (hi::*current-buffer* buffer)) - - (invoke-modifying-buffer-storage + (hemlock-ext:invoke-modifying-buffer-storage buffer #'(lambda () Index: /branches/event-ide/ccl/cocoa-ide/hemlock/src/bindings.lisp =================================================================== --- /branches/event-ide/ccl/cocoa-ide/hemlock/src/bindings.lisp (revision 7918) +++ /branches/event-ide/ccl/cocoa-ide/hemlock/src/bindings.lisp (revision 7919) @@ -976,2 +976,7 @@ (setf (logical-key-event-p #k"control-q" :quote) t) (setf (logical-key-event-p #k"k" :keep) t) +(setf (logical-key-event-p #k"y" :y) t) +(setf (logical-key-event-p #k"Y" :y) t) +(setf (logical-key-event-p #k"n" :n) t) +(setf (logical-key-event-p #k"N" :n) t) + Index: /branches/event-ide/ccl/cocoa-ide/hemlock/src/command.lisp =================================================================== --- /branches/event-ide/ccl/cocoa-ide/hemlock/src/command.lisp (revision 7918) +++ /branches/event-ide/ccl/cocoa-ide/hemlock/src/command.lisp (revision 7919) @@ -449,5 +449,5 @@ (assert (ps-result ps)) (setf (ps-set-p ps) t) - #+GZ (gui::log-debug "Note prefix argument set: ~s" ps) + #+GZ (log-debug "Note prefix argument set: ~s" ps) (message (with-output-to-string (s) (dotimes (i (ps-multiplier ps)) Index: /branches/event-ide/ccl/cocoa-ide/hemlock/src/echo.lisp =================================================================== --- /branches/event-ide/ccl/cocoa-ide/hemlock/src/echo.lisp (revision 7918) +++ /branches/event-ide/ccl/cocoa-ide/hemlock/src/echo.lisp (revision 7919) @@ -45,5 +45,5 @@ (let ((message (apply #'format nil string args))) (modifying-echo-buffer - (delete-region (buffer-region *current-buffer*)) + (delete-region (buffer-region *current-buffer*)) (insert-string (buffer-point *current-buffer*) message) (setq *last-message-time* (get-internal-real-time)) @@ -86,9 +86,11 @@ ;; Help string for the current parse. (parse-help ()) - ;; A hack. :String, :File or :Keyword. + ;; :String, :File or :Keyword. (parse-type :string) ;; input region parse-starting-mark parse-input-region + ;; key handler, nil to use the standard one + (parse-key-handler nil) ;; Store result here (parse-results ())) @@ -130,5 +132,6 @@ default prompt - help) + help + key-handler) ;; We can't do a "recursive" edit in more than one view, because if the earlier ;; one wants to exit first, we'd have to unwind the stack to allow it to exit, @@ -153,5 +156,6 @@ :parse-default default :parse-prompt prompt - :parse-help help))) + :parse-help help + :parse-key-handler key-handler))) ;; TODO: There is really no good reason to disallow recursive edits in the same ;; buffer, I'm just too lazy. Should save contents, starting mark, and point, @@ -168,5 +172,5 @@ (with-standard-standard-output (gui::event-loop #'(lambda () (eps-parse-results eps))))) - #+gz (gui::log-debug "~&Event loop exited!, results = ~s" (eps-parse-results eps))) + #+gz (log-debug "~&Event loop exited!, results = ~s" (eps-parse-results eps))) (setf (hemlock-prompted-input-state view) old-eps) (unless old-eps @@ -179,5 +183,5 @@ (defun exit-echo-parse (eps results) - #+gz (gui::log-debug "~&exit echo parse, results = ~s" results) + #+gz (log-debug "~&exit echo parse, results = ~s" results) ;; Must be set to non-nil to indicate parse done. (setf (eps-parse-results eps) (or results '(nil))) @@ -499,31 +503,34 @@ :help help)) -#+not-yet -(defun prompt-for-y-or-n (&key ((:must-exist must-exist) t) +(defun prompt-for-y-or-n (&key (must-exist t) (default nil defaultp) default-string - ((:prompt prompt) "Y or N? ") - ((:help *parse-help*) "Type Y or N.")) + (prompt "Y or N? ") + (help "Type Y or N.")) "Prompts for Y or N." - (with-echo-area-window - (display-prompt-nicely prompt (or default-string - (if defaultp (if default "Y" "N")))) - (loop - (let ((key-event (recursive-get-key-event *editor-input*))) - (cond ((or (eq key-event #k"y") - (eq key-event #k"Y")) - (return t)) - ((or (eq key-event #k"n") - (eq key-event #k"N")) - (return nil)) - ((logical-key-event-p key-event :confirm) - (if defaultp - (return default) - (beep))) - ((logical-key-event-p key-event :help) - (hemlock::help-on-parse-command ())) - (t - (unless must-exist (return key-event)) - (beep))))))) + (parse-for-something + :verification-function #'(lambda (eps key-event) + (cond ((logical-key-event-p key-event :y) + (values (list t) t)) + ((logical-key-event-p key-event :n) + (values (list nil) t)) + ((and (eps-parse-default eps) + (logical-key-event-p key-event :confirm)) + (values (list (equalp (eps-parse-default eps) "y")) t)) + ((logical-key-event-p key-event :abort) + (values nil nil)) ;; default action + ((logical-key-event-p key-event :help) + (values nil nil)) ;; default action + (t + (if (eps-parse-value-must-exist eps) + (values nil nil) ;; default action + (values (list key-event) t))))) + :type :key + :value-must-exist must-exist + :default-string default-string + :default (and defaultp (if default "Y" "N")) + :prompt prompt + :help help + :key-handler (getstring "Key Input Handler" *command-names*))) @@ -532,20 +539,21 @@ ;;;; Key-event and key prompting. +(defun prompt-for-key-event (&key (prompt "Key-event: ") + (help "Type any key")) + "Prompts for a key-event." + (prompt-for-something + :verification-function #'(lambda (eps key-event) + (declare (ignore eps)) + (values (list key-event) t)) + :type :key + :prompt prompt + :help help + :key-handler (getstring "Key Input Handler" *command-names*))) + #+not-yet -(defun prompt-for-key-event (&key (prompt "Key-event: ") (change-window t)) - "Prompts for a key-event." - (if change-window - (with-echo-area-window - (display-prompt-nicely prompt) - (recursive-get-key-event *editor-input* t)) - (progn - (display-prompt-nicely prompt) - (recursive-get-key-event *editor-input* t)))) - -#+not-yet -(defun prompt-for-key (&key ((:must-exist must-exist) t) +(defun prompt-for-key (&key (must-exist t) default default-string (prompt "Key: ") - ((:help *parse-help*) "Type a key.")) + (help "Type a key.")) (let ((string (if default (or default-string @@ -707,14 +715,6 @@ ;;;; Some standard logical-key-events: -(define-logical-key-event "Forward Search" - "This key-event is used to indicate that a forward search should be made.") -(define-logical-key-event "Backward Search" - "This key-event is used to indicate that a backward search should be made.") -(define-logical-key-event "Cancel" - "This key-event is used to cancel a previous key-event of input.") (define-logical-key-event "Abort" "This key-event is used to abort the command in progress.") -(define-logical-key-event "Exit" - "This key-event is used to exit normally the command in progress.") (define-logical-key-event "Yes" "This key-event is used to indicate a positive response.") @@ -733,8 +733,8 @@ (define-logical-key-event "Keep" "This key-event means exit but keep something around.") -(define-logical-key-event "Mouse Exit" - "This key-event means exit completely.") -(define-logical-key-event "Extend Search Word" - "This key-event means to extend the incremental search string by the word after the point") +(define-logical-key-event "y" + "This key-event is used to indicate a short positive response.") +(define-logical-key-event "n" + "This key-event is used to indicate a short negative response.") Index: /branches/event-ide/ccl/cocoa-ide/hemlock/src/echocoms.lisp =================================================================== --- /branches/event-ide/ccl/cocoa-ide/hemlock/src/echocoms.lisp (revision 7918) +++ /branches/event-ide/ccl/cocoa-ide/hemlock/src/echocoms.lisp (revision 7919) @@ -340,2 +340,20 @@ (when (mark< point start) (beginning-of-parse-command nil)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; + +(defcommand "Key Input Handler" (p) + "Internal command to handle input during y-or-n or key-event prompting" + (declare (ignore p)) + (let* ((eps (current-echo-parse-state)) + (key-event (last-key-event-typed))) + (multiple-value-bind (res flag) + (funcall (eps-parse-verification-function eps) eps key-event) + (if flag + (exit-echo-parse eps res) + (cond ((logical-key-event-p key-event :abort) + (abort-to-toplevel)) + ((logical-key-event-p key-event :help) + (hemlock::help-on-parse-command nil)) + (t (beep))))))) Index: /branches/event-ide/ccl/cocoa-ide/hemlock/src/macros.lisp =================================================================== --- /branches/event-ide/ccl/cocoa-ide/hemlock/src/macros.lisp (revision 7918) +++ /branches/event-ide/ccl/cocoa-ide/hemlock/src/macros.lisp (revision 7919) @@ -99,7 +99,7 @@ (defmacro modifying-buffer-storage ((buffer) &body body) (if (eq buffer '*current-buffer*) - `(gui::invoke-modifying-buffer-storage *current-buffer* #'(lambda () ,@body)) + `(hemlock-ext:invoke-modifying-buffer-storage *current-buffer* #'(lambda () ,@body)) `(let ((*current-buffer* ,buffer)) - (gui::invoke-modifying-buffer-storage *current-buffer* #'(lambda () ,@body))))) + (hemlock-ext:invoke-modifying-buffer-storage *current-buffer* #'(lambda () ,@body))))) @@ -406,12 +406,11 @@ ); eval-when ;;; -(defmacro command-case ((&key (change-window t) - (prompt "Command character: ") +(defmacro command-case ((&key (prompt "Command character: ") (help "Choose one of the following characters:") (bind (gensym))) &body forms) - "This is analogous to the Common Lisp CASE macro. Commands such as \"Query - Replace\" use this to get a key-event, translate it to a character, and - then to dispatch on the character to the specified case. The syntax is + "This is analogous to the Common Lisp CASE macro. Commands can use this + to get a key-event, translate it to a character, and then to dispatch on + the character to the specified case. The syntax is as follows: (COMMAND-CASE ( {key value}* ) @@ -422,6 +421,5 @@ EXT:KEY-EVENT-CHAR. - The legal keys of the key/value pairs are :help, :prompt, :change-window, - and :bind. See the manual for details." + The legal keys of the key/value pairs are :help, :prompt, and :bind." (do* ((forms forms (cdr forms)) (form (car forms) (car forms)) @@ -430,5 +428,4 @@ (again (gensym)) (n-prompt (gensym)) - (n-change (gensym)) (bind-char (gensym)) (docs ()) @@ -438,13 +435,12 @@ `(progn (setf ,',bind - (prompt-for-key-event :prompt ,',n-prompt :change-window ,',n-change)) + (prompt-for-key-event :prompt ,',n-prompt)) (setf ,',bind-char (hemlock-ext:key-event-char ,',bind)) (go ,',again)))) (block ,bname (let* ((,n-prompt ,prompt) - (,n-change ,change-window) - (,bind (prompt-for-key-event :prompt ,n-prompt :change-window ,n-change)) + (,bind (prompt-for-key-event :prompt ,n-prompt)) (,bind-char (hemlock-ext:key-event-char ,bind))) - (declare (ignorable ,n-prompt ,n-change ,bind ,bind-char)) + (declare (ignorable,bind ,bind-char)) (tagbody ,again Index: /branches/event-ide/ccl/cocoa-ide/hemlock/src/package.lisp =================================================================== --- /branches/event-ide/ccl/cocoa-ide/hemlock/src/package.lisp (revision 7918) +++ /branches/event-ide/ccl/cocoa-ide/hemlock/src/package.lisp (revision 7919) @@ -352,4 +352,5 @@ ;; defined externally (i.e. used by but not defined in hemlock) + #:invoke-modifying-buffer-storage #:note-selection-set-by-search #:center-selection-in-view @@ -484,5 +485,5 @@ #:eps-parse-type #:eps-parse-starting-mark #:eps-parse-input-region #:eps-parse-verification-function #:eps-parse-string-tables - #:eps-parse-default #:eps-parse-help + #:eps-parse-default #:eps-parse-help #:eps-parse-key-handler #:prompt-for-buffer #:prompt-for-file #:prompt-for-integer #:prompt-for-keyword #:prompt-for-expression #:prompt-for-string Index: /branches/event-ide/ccl/cocoa-ide/hemlock/src/searchcoms.lisp =================================================================== --- /branches/event-ide/ccl/cocoa-ide/hemlock/src/searchcoms.lisp (revision 7918) +++ /branches/event-ide/ccl/cocoa-ide/hemlock/src/searchcoms.lisp (revision 7919) @@ -256,5 +256,6 @@ "Query replace: " :help "Type one of the following single-character commands:" - :change-window nil :bind key-event) + #| :change-window nil |# + :bind key-event) (:yes "Replace this occurrence." (replace-that-case replacement cap upper point length Index: /branches/event-ide/ccl/cocoa-ide/hemlock/src/views.lisp =================================================================== --- /branches/event-ide/ccl/cocoa-ide/hemlock/src/views.lisp (revision 7918) +++ /branches/event-ide/ccl/cocoa-ide/hemlock/src/views.lisp (revision 7919) @@ -160,5 +160,7 @@ (if (shiftf (hemlock-view-quote-next-p view) nil) (values (get-self-insert-command) nil) - (translate-and-lookup-current-command view)) + (let ((eps (hemlock-prompted-input-state view))) + (or (and eps (eps-parse-key-handler eps)) + (translate-and-lookup-current-command view)))) (when main-binding (setf (fill-pointer (hemlock-current-command view)) 0)) @@ -169,6 +171,5 @@ ;;; -(defvar *invoke-hook* #'(lambda (command p) - (funcall (command-function command) p)) +(defvar *invoke-hook* #'(lambda (command p) (funcall (command-function command) p)) "This function is called by the command interpreter when it wants to invoke a command. The arguments are the command to invoke and the prefix argument. @@ -213,4 +214,8 @@ (hemlock-echo-area-buffer view) (hemlock-view-buffer view))) + +(defun buffer-modification-state (buffer) + (multiple-value-bind (start end) (buffer-selection-range buffer) + (list* (buffer-signature buffer) start end))) (defmethod handle-hemlock-event ((view hemlock-view) key) @@ -232,6 +237,6 @@ (let* ((*current-view* view) (*current-buffer* (hemlock-view-current-buffer view)) - (start-sig (buffer-signature *current-buffer*)) - (sel (multiple-value-list (buffer-selection-range *current-buffer*)))) + (text-buffer (hemlock-view-buffer view)) + (mod (buffer-modification-state text-buffer))) (with-buffer-bindings (*current-buffer*) (modifying-buffer-storage (*current-buffer*) @@ -240,7 +245,5 @@ (execute-hemlock-key view key)) (exit-event-handler () :report "Exit from hemlock event handler"))) - (unless (and (eql start-sig (buffer-signature *current-buffer*)) - (multiple-value-bind (s e) (buffer-selection-range *current-buffer*) - (and (eql s (car sel)) (eql e (cadr sel))))) + (unless (equal mod (buffer-modification-state text-buffer)) ;; Modified buffer, make sure user sees what happened (hemlock-ext:ensure-selection-visible view))