Changeset 7919


Ignore:
Timestamp:
Dec 18, 2007, 3:48:30 PM (12 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:
9 edited

Legend:

Unmodified
Added
Removed
  • branches/event-ide/ccl/cocoa-ide/cocoa-editor.lisp

    r7911 r7919  
    19331933  (release-lock (hi::buffer-lock b)))
    19341934
    1935 (defun invoke-modifying-buffer-storage (buffer thunk)
     1935(defun hemlock-ext:invoke-modifying-buffer-storage (buffer thunk)
    19361936  (assume-cocoa-thread)
    19371937  (when buffer ;; nil means just get rid of any prior buffer
     
    22672267         (point (hi::buffer-point buffer))
    22682268         (pointpos (hi:mark-absolute-position point)))
    2269     (invoke-modifying-buffer-storage
     2269    (hemlock-ext:invoke-modifying-buffer-storage
    22702270     buffer
    22712271     #'(lambda ()
     
    23502350                 (display (hemlock-buffer-string-cache (#/hemlockString textstorage)))
    23512351                 (hi::*current-buffer* buffer))
    2352            
    2353             (invoke-modifying-buffer-storage
     2352            (hemlock-ext:invoke-modifying-buffer-storage
    23542353             buffer
    23552354             #'(lambda ()
  • branches/event-ide/ccl/cocoa-ide/hemlock/src/bindings.lisp

    r7898 r7919  
    976976(setf (logical-key-event-p #k"control-q" :quote) t)
    977977(setf (logical-key-event-p #k"k" :keep) t)
     978(setf (logical-key-event-p #k"y" :y) t)
     979(setf (logical-key-event-p #k"Y" :y) t)
     980(setf (logical-key-event-p #k"n" :n) t)
     981(setf (logical-key-event-p #k"N" :n) t)
     982
  • branches/event-ide/ccl/cocoa-ide/hemlock/src/command.lisp

    r7913 r7919  
    449449  (assert (ps-result ps))
    450450  (setf (ps-set-p ps) t)
    451   #+GZ (gui::log-debug "Note prefix argument set: ~s" ps)
     451  #+GZ (log-debug "Note prefix argument set: ~s" ps)
    452452  (message (with-output-to-string (s)
    453453             (dotimes (i (ps-multiplier ps))
  • branches/event-ide/ccl/cocoa-ide/hemlock/src/echo.lisp

    r7911 r7919  
    4545      (let ((message (apply #'format nil string args)))
    4646        (modifying-echo-buffer
    47          (delete-region (buffer-region *current-buffer*))
     47          (delete-region (buffer-region *current-buffer*))
    4848         (insert-string (buffer-point *current-buffer*) message)
    4949         (setq *last-message-time* (get-internal-real-time))
     
    8686  ;; Help string for the current parse.
    8787  (parse-help ())
    88   ;; A hack. :String, :File or :Keyword.
     88  ;; :String, :File or :Keyword.
    8989  (parse-type :string)
    9090  ;; input region
    9191  parse-starting-mark
    9292  parse-input-region
     93  ;; key handler, nil to use the standard one
     94  (parse-key-handler nil)
    9395  ;; Store result here
    9496  (parse-results ()))
     
    130132                                 default
    131133                                 prompt
    132                                  help)
     134                                 help
     135                                 key-handler)
    133136  ;; We can't do a "recursive" edit in more than one view, because if the earlier
    134137  ;; one wants to exit first, we'd have to unwind the stack to allow it to exit,
     
    153156                :parse-default default
    154157                :parse-prompt prompt
    155                 :parse-help help)))
     158                :parse-help help
     159                :parse-key-handler key-handler)))
    156160     ;; TODO: There is really no good reason to disallow recursive edits in the same
    157161     ;; buffer, I'm just too lazy.  Should save contents, starting mark, and point,
     
    168172             (with-standard-standard-output
    169173              (gui::event-loop #'(lambda () (eps-parse-results eps)))))
    170            #+gz (gui::log-debug "~&Event loop exited!, results = ~s" (eps-parse-results eps)))
     174           #+gz (log-debug "~&Event loop exited!, results = ~s" (eps-parse-results eps)))
    171175       (setf (hemlock-prompted-input-state view) old-eps)
    172176       (unless old-eps
     
    179183
    180184(defun exit-echo-parse (eps results)
    181   #+gz (gui::log-debug "~&exit echo parse, results = ~s" results)
     185  #+gz (log-debug "~&exit echo parse, results = ~s" results)
    182186  ;; Must be set to non-nil to indicate parse done.
    183187  (setf (eps-parse-results eps) (or results '(nil)))
     
    499503   :help help))
    500504
    501 #+not-yet
    502 (defun prompt-for-y-or-n (&key ((:must-exist must-exist) t)
     505(defun prompt-for-y-or-n (&key (must-exist t)
    503506                               (default nil defaultp)
    504507                               default-string
    505                                ((:prompt prompt) "Y or N? ")
    506                                ((:help *parse-help*) "Type Y or N."))
     508                               (prompt "Y or N? ")
     509                               (help "Type Y or N."))
    507510  "Prompts for Y or N."
    508   (with-echo-area-window
    509    (display-prompt-nicely prompt (or default-string
    510                                      (if defaultp (if default "Y" "N"))))
    511    (loop
    512      (let ((key-event (recursive-get-key-event *editor-input*)))
    513        (cond ((or (eq key-event #k"y")
    514                   (eq key-event #k"Y"))
    515               (return t))
    516              ((or (eq key-event #k"n")
    517                   (eq key-event #k"N"))
    518               (return nil))
    519              ((logical-key-event-p key-event :confirm)
    520               (if defaultp
    521                 (return default)
    522                 (beep)))
    523              ((logical-key-event-p key-event :help)
    524               (hemlock::help-on-parse-command ()))
    525              (t
    526               (unless must-exist (return key-event))
    527               (beep)))))))
     511  (parse-for-something
     512   :verification-function #'(lambda (eps key-event)
     513                              (cond ((logical-key-event-p key-event :y)
     514                                     (values (list t) t))
     515                                    ((logical-key-event-p key-event :n)
     516                                     (values (list nil) t))
     517                                    ((and (eps-parse-default eps)
     518                                          (logical-key-event-p key-event :confirm))
     519                                     (values (list (equalp (eps-parse-default eps) "y")) t))
     520                                    ((logical-key-event-p key-event :abort)
     521                                     (values nil nil)) ;; default action
     522                                    ((logical-key-event-p key-event :help)
     523                                     (values nil nil)) ;; default action
     524                                    (t
     525                                     (if (eps-parse-value-must-exist eps)
     526                                       (values nil nil) ;; default action
     527                                       (values (list key-event) t)))))
     528   :type :key
     529   :value-must-exist must-exist
     530   :default-string default-string
     531   :default (and defaultp (if default "Y" "N"))
     532   :prompt prompt
     533   :help help
     534   :key-handler (getstring "Key Input Handler" *command-names*)))
    528535
    529536
     
    532539;;;; Key-event and key prompting.
    533540
     541(defun prompt-for-key-event (&key (prompt "Key-event: ")
     542                                  (help "Type any key"))
     543  "Prompts for a key-event."
     544  (prompt-for-something
     545   :verification-function #'(lambda (eps key-event)
     546                              (declare (ignore eps))
     547                              (values (list key-event) t))
     548   :type :key
     549   :prompt prompt
     550   :help help
     551   :key-handler (getstring "Key Input Handler" *command-names*)))
     552
    534553#+not-yet
    535 (defun prompt-for-key-event (&key (prompt "Key-event: ") (change-window t))
    536   "Prompts for a key-event."
    537   (if change-window
    538     (with-echo-area-window
    539      (display-prompt-nicely prompt)
    540      (recursive-get-key-event *editor-input* t))
    541     (progn
    542      (display-prompt-nicely prompt)
    543      (recursive-get-key-event *editor-input* t))))
    544 
    545 #+not-yet
    546 (defun prompt-for-key (&key ((:must-exist must-exist) t)
     554(defun prompt-for-key (&key (must-exist t)
    547555                            default default-string
    548556                            (prompt "Key: ")
    549                             ((:help *parse-help*) "Type a key."))
     557                            (help "Type a key."))
    550558  (let ((string (if default
    551559                  (or default-string
     
    707715;;;; Some standard logical-key-events:
    708716
    709 (define-logical-key-event "Forward Search"
    710   "This key-event is used to indicate that a forward search should be made.")
    711 (define-logical-key-event "Backward Search"
    712   "This key-event is used to indicate that a backward search should be made.")
    713 (define-logical-key-event "Cancel"
    714   "This key-event is used  to cancel a previous key-event of input.")
    715717(define-logical-key-event "Abort"
    716718  "This key-event is used to abort the command in progress.")
    717 (define-logical-key-event "Exit"
    718   "This key-event is used to exit normally the command in progress.")
    719719(define-logical-key-event "Yes"
    720720  "This key-event is used to indicate a positive response.")
     
    733733(define-logical-key-event "Keep"
    734734  "This key-event means exit but keep something around.")
    735 (define-logical-key-event "Mouse Exit"
    736   "This key-event means exit completely.")
    737 (define-logical-key-event "Extend Search Word"
    738   "This key-event means to extend the incremental search string by the word after the point")
     735(define-logical-key-event "y"
     736  "This key-event is used to indicate a short positive response.")
     737(define-logical-key-event "n"
     738  "This key-event is used to indicate a short negative response.")
    739739
    740740
  • branches/event-ide/ccl/cocoa-ide/hemlock/src/echocoms.lisp

    r7844 r7919  
    340340    (when (mark< point start)
    341341      (beginning-of-parse-command nil))))
     342
     343;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     344;;
     345
     346(defcommand "Key Input Handler" (p)
     347  "Internal command to handle input during y-or-n or key-event prompting"
     348  (declare (ignore p))
     349  (let* ((eps (current-echo-parse-state))
     350         (key-event (last-key-event-typed)))
     351    (multiple-value-bind (res flag)
     352                         (funcall (eps-parse-verification-function eps) eps key-event)
     353      (if flag
     354        (exit-echo-parse eps res)
     355        (cond ((logical-key-event-p key-event :abort)
     356               (abort-to-toplevel))
     357              ((logical-key-event-p key-event :help)
     358               (hemlock::help-on-parse-command nil))
     359              (t (beep)))))))
  • branches/event-ide/ccl/cocoa-ide/hemlock/src/macros.lisp

    r7911 r7919  
    9999(defmacro modifying-buffer-storage ((buffer) &body body)
    100100  (if (eq buffer '*current-buffer*)
    101     `(gui::invoke-modifying-buffer-storage *current-buffer* #'(lambda () ,@body))
     101    `(hemlock-ext:invoke-modifying-buffer-storage *current-buffer* #'(lambda () ,@body))
    102102    `(let ((*current-buffer* ,buffer))
    103        (gui::invoke-modifying-buffer-storage *current-buffer* #'(lambda () ,@body)))))
     103       (hemlock-ext:invoke-modifying-buffer-storage *current-buffer* #'(lambda () ,@body)))))
    104104
    105105
     
    406406); eval-when
    407407;;; 
    408 (defmacro command-case ((&key (change-window t)
    409                               (prompt "Command character: ")
     408(defmacro command-case ((&key (prompt "Command character: ")
    410409                              (help "Choose one of the following characters:")
    411410                              (bind (gensym)))
    412411                        &body forms)
    413   "This is analogous to the Common Lisp CASE macro.  Commands such as \"Query
    414    Replace\" use this to get a key-event, translate it to a character, and
    415    then to dispatch on the character to the specified case.  The syntax is
     412  "This is analogous to the Common Lisp CASE macro.  Commands can use this
     413   to get a key-event, translate it to a character, and then to dispatch on
     414   the character to the specified case.  The syntax is
    416415   as follows:
    417416      (COMMAND-CASE ( {key value}* )
     
    422421   EXT:KEY-EVENT-CHAR.
    423422
    424    The legal keys of the key/value pairs are :help, :prompt, :change-window,
    425    and :bind.  See the manual for details."
     423   The legal keys of the key/value pairs are :help, :prompt, and :bind."
    426424  (do* ((forms forms (cdr forms))
    427425        (form (car forms) (car forms))
     
    430428        (again (gensym))
    431429        (n-prompt (gensym))
    432         (n-change (gensym))
    433430        (bind-char (gensym))
    434431        (docs ())
     
    438435                      `(progn
    439436                         (setf ,',bind
    440                                (prompt-for-key-event :prompt ,',n-prompt :change-window ,',n-change))
     437                               (prompt-for-key-event :prompt ,',n-prompt))
    441438                         (setf ,',bind-char (hemlock-ext:key-event-char ,',bind))
    442439                         (go ,',again))))
    443440           (block ,bname
    444441             (let* ((,n-prompt ,prompt)
    445                     (,n-change ,change-window)
    446                     (,bind (prompt-for-key-event :prompt ,n-prompt :change-window ,n-change))
     442                    (,bind (prompt-for-key-event :prompt ,n-prompt))
    447443                    (,bind-char (hemlock-ext:key-event-char ,bind)))
    448                (declare (ignorable ,n-prompt ,n-change ,bind ,bind-char))
     444               (declare (ignorable,bind ,bind-char))
    449445               (tagbody
    450446                ,again
  • branches/event-ide/ccl/cocoa-ide/hemlock/src/package.lisp

    r7913 r7919  
    352352
    353353   ;; defined externally (i.e. used by but not defined in hemlock)
     354   #:invoke-modifying-buffer-storage
    354355   #:note-selection-set-by-search
    355356   #:center-selection-in-view
     
    484485   #:eps-parse-type #:eps-parse-starting-mark #:eps-parse-input-region
    485486   #:eps-parse-verification-function #:eps-parse-string-tables
    486    #:eps-parse-default #:eps-parse-help
     487   #:eps-parse-default #:eps-parse-help #:eps-parse-key-handler
    487488   #:prompt-for-buffer #:prompt-for-file #:prompt-for-integer
    488489   #:prompt-for-keyword #:prompt-for-expression #:prompt-for-string
  • branches/event-ide/ccl/cocoa-ide/hemlock/src/searchcoms.lisp

    r7844 r7919  
    256256                    "Query replace: "
    257257                    :help "Type one of the following single-character commands:"
    258                     :change-window nil :bind key-event)
     258                    #| :change-window nil |#
     259                    :bind key-event)
    259260                 (:yes "Replace this occurrence."
    260261                       (replace-that-case replacement cap upper point length
  • branches/event-ide/ccl/cocoa-ide/hemlock/src/views.lisp

    r7911 r7919  
    160160                       (if (shiftf (hemlock-view-quote-next-p view) nil)
    161161                         (values (get-self-insert-command) nil)
    162                          (translate-and-lookup-current-command view))
     162                         (let ((eps (hemlock-prompted-input-state view)))
     163                           (or (and eps (eps-parse-key-handler eps))
     164                               (translate-and-lookup-current-command view))))
    163165    (when main-binding
    164166      (setf (fill-pointer (hemlock-current-command view)) 0))
     
    169171
    170172;;;
    171 (defvar *invoke-hook* #'(lambda (command p)
    172                           (funcall (command-function command) p))
     173(defvar *invoke-hook* #'(lambda (command p) (funcall (command-function command) p))
    173174  "This function is called by the command interpreter when it wants to invoke a
    174175  command.  The arguments are the command to invoke and the prefix argument.
     
    213214    (hemlock-echo-area-buffer view)
    214215    (hemlock-view-buffer view)))
     216
     217(defun buffer-modification-state (buffer)
     218  (multiple-value-bind (start end) (buffer-selection-range buffer)
     219    (list* (buffer-signature buffer) start end)))
    215220
    216221(defmethod handle-hemlock-event ((view hemlock-view) key)
     
    232237      (let* ((*current-view* view)
    233238             (*current-buffer* (hemlock-view-current-buffer view))
    234              (start-sig (buffer-signature *current-buffer*))
    235              (sel (multiple-value-list (buffer-selection-range *current-buffer*))))
     239             (text-buffer (hemlock-view-buffer view))
     240             (mod (buffer-modification-state text-buffer)))
    236241        (with-buffer-bindings (*current-buffer*)
    237242          (modifying-buffer-storage (*current-buffer*)
     
    240245                  (execute-hemlock-key view key))
    241246              (exit-event-handler () :report "Exit from hemlock event handler")))
    242           (unless (and (eql start-sig (buffer-signature *current-buffer*))
    243                        (multiple-value-bind (s e) (buffer-selection-range *current-buffer*)
    244                          (and (eql s (car sel)) (eql e (cadr sel)))))
     247          (unless (equal mod (buffer-modification-state text-buffer))
    245248            ;; Modified buffer, make sure user sees what happened
    246249            (hemlock-ext:ensure-selection-visible view))
Note: See TracChangeset for help on using the changeset viewer.