Changeset 7919

Timestamp:

Dec 18, 2007, 7:48:30 AM (17 years ago)

Author:

gz

Message:

Implement prompt-for-y-or-n and prompt-for-key-event (and hence command-case)
except don't suport the :change-window nil case (i.e. query-replace).

Get rid of obsolete logical key events from old isearch implementation.

Put invoke-modifying-buffer-storage in hemlock-ext:

Ensure selection is visible if selection changed, even if buffer contents didn't.

Location:

branches/event-ide/ccl/cocoa-ide

Files:

• cocoa-editor.lisp (modified) (3 diffs)
• hemlock/src/bindings.lisp (modified) (1 diff)
• hemlock/src/command.lisp (modified) (1 diff)
• hemlock/src/echo.lisp (modified) (10 diffs)
• hemlock/src/echocoms.lisp (modified) (1 diff)
• hemlock/src/macros.lisp (modified) (5 diffs)
• hemlock/src/package.lisp (modified) (2 diffs)
• hemlock/src/searchcoms.lisp (modified) (1 diff)
• hemlock/src/views.lisp (modified) (5 diffs)

branches/event-ide/ccl/cocoa-ide/cocoa-editor.lisp

@@ -1933 +1933 @@
   (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 +2267 @@
          (point (hi::buffer-point buffer))
          (pointpos (hi:mark-absolute-position point)))
-    (invoke-modifying-buffer-storage
+    (hemlock-ext:invoke-modifying-buffer-storage
      buffer
      #'(lambda ()
@@ -2350 +2350 @@
                  (display (hemlock-buffer-string-cache (#/hemlockString textstorage)))
                  (hi::*current-buffer* buffer))
-            
-            (invoke-modifying-buffer-storage
+            (hemlock-ext:invoke-modifying-buffer-storage
              buffer
              #'(lambda ()

branches/event-ide/ccl/cocoa-ide/hemlock/src/bindings.lisp

@@ -976 +976 @@
 (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)
+

branches/event-ide/ccl/cocoa-ide/hemlock/src/command.lisp

@@ -449 +449 @@
   (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))

branches/event-ide/ccl/cocoa-ide/hemlock/src/echo.lisp

@@ -45 +45 @@
       (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 +86 @@
   ;; 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 +132 @@
                                  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 +156 @@
                 :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 +172 @@
              (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 +183 @@
 
 (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 +503 @@
    :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 +539 @@
 ;;;; 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 +715 @@
 ;;;; 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 +733 @@
 (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.")
 
 

branches/event-ide/ccl/cocoa-ide/hemlock/src/echocoms.lisp

@@ -340 +340 @@
     (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)))))))

branches/event-ide/ccl/cocoa-ide/hemlock/src/macros.lisp

@@ -99 +99 @@
 (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 +406 @@
 ); 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 +421 @@
    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 +428 @@
         (again (gensym))
         (n-prompt (gensym))
-        (n-change (gensym))
         (bind-char (gensym))
         (docs ())
@@ -438 +435 @@
                       `(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

branches/event-ide/ccl/cocoa-ide/hemlock/src/package.lisp

@@ -352 +352 @@
 
    ;; 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 +485 @@
    #: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

branches/event-ide/ccl/cocoa-ide/hemlock/src/searchcoms.lisp

@@ -256 +256 @@
                     "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

branches/event-ide/ccl/cocoa-ide/hemlock/src/views.lisp

@@ -160 +160 @@
                        (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 +171 @@
 
 ;;;
-(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 +214 @@
     (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 +237 @@
       (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 +245 @@
                   (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))