;; FIXME: Clean up namespace usage!
-(declare-function frameset-register-p "frameset")
-
(cl-defstruct
(registerv (:constructor nil)
(:constructor registerv--make (&optional data print-func
:version "24.4"
:type '(choice number (const :tag "No preview unless requested" nil))
:group 'register)
-(make-obsolete-variable 'register-preview-delay "No longer used." "30.1")
-
-(defcustom register-preview-default-keys (mapcar #'string (number-sequence ?a ?z))
- "Default keys for setting a new register."
- :type '(repeat string))
-
-(defcustom register-use-preview t
- "Always show register preview when non nil."
- :type 'boolean)
(defun get-register (register)
"Return contents of Emacs register named REGISTER, or nil if none."
(defun register-preview-default (r)
"Function that is the default value of the variable `register-preview-function'."
(format "%s: %s\n"
- (propertize (string (car r))
- 'display (single-key-description (car r)))
+ (single-key-description (car r))
(register-describe-oneline (car r))))
(defvar register-preview-function #'register-preview-default
Called with one argument, a cons (NAME . CONTENTS) as found in `register-alist'.
The function should return a string, the description of the argument.")
-(cl-defstruct register-preview-info
- "Store data for a specific register command.
-TYPES are the types of register supported.
-MSG is the minibuffer message to send when a register is selected.
-ACT is the type of action the command is doing on register.
-SMATCH accept a boolean value to say if command accept non matching register."
- types msg act smatch)
-
-(cl-defgeneric register-command-info (command)
- "Returns a `register-preview-info' object storing data for COMMAND."
- (ignore command))
-(cl-defmethod register-command-info ((_command (eql insert-register)))
- (make-register-preview-info
- :types '(string number)
- :msg "Insert register `%s'"
- :act 'insert
- :smatch t))
-(cl-defmethod register-command-info ((_command (eql jump-to-register)))
- (make-register-preview-info
- :types '(window frame marker kmacro
- file buffer file-query)
- :msg "Jump to register `%s'"
- :act 'jump
- :smatch t))
-(cl-defmethod register-command-info ((_command (eql view-register)))
- (make-register-preview-info
- :types '(all)
- :msg "View register `%s'"
- :act 'view
- :smatch t))
-(cl-defmethod register-command-info ((_command (eql append-to-register)))
- (make-register-preview-info
- :types '(string number)
- :msg "Append to register `%s'"
- :act 'modify
- :smatch t))
-(cl-defmethod register-command-info ((_command (eql prepend-to-register)))
- (make-register-preview-info
- :types '(string number)
- :msg "Prepend to register `%s'"
- :act 'modify
- :smatch t))
-(cl-defmethod register-command-info ((_command (eql increment-register)))
- (make-register-preview-info
- :types '(string number)
- :msg "Increment register `%s'"
- :act 'modify
- :smatch t))
-
-(defun register-preview-forward-line (arg)
- "Move to next or previous line in register preview buffer.
-If ARG is positive goto next line, if negative to previous.
-Do nothing when defining or executing kmacros."
- ;; Ensure user enter manually key in minibuffer when recording a macro.
- (unless (or defining-kbd-macro executing-kbd-macro
- (not (get-buffer-window "*Register Preview*" 'visible)))
- (let ((fn (if (> arg 0) #'eobp #'bobp))
- (posfn (if (> arg 0)
- #'point-min
- (lambda () (1- (point-max)))))
- str)
- (with-current-buffer "*Register Preview*"
- (let ((ovs (overlays-in (point-min) (point-max)))
- pos)
- (goto-char (if ovs
- (overlay-start (car ovs))
- (point-min)))
- (setq pos (point))
- (and ovs (forward-line arg))
- (when (and (funcall fn)
- (or (> arg 0) (eql pos (point))))
- (goto-char (funcall posfn)))
- (setq str (buffer-substring-no-properties
- (pos-bol) (1+ (pos-bol))))
- (remove-overlays)
- (with-selected-window (minibuffer-window)
- (delete-minibuffer-contents)
- (insert str)))))))
-
-(defun register-preview-next ()
- "Goto next line in register preview buffer."
- (interactive)
- (register-preview-forward-line 1))
-
-(defun register-preview-previous ()
- "Goto previous line in register preview buffer."
- (interactive)
- (register-preview-forward-line -1))
-
-(defun register-type (register)
- "Return REGISTER type.
-Current register types actually returned are one of:
-- string
-- number
-- marker
-- buffer
-- file
-- file-query
-- window
-- frame
-- kmacro
-
-One can add new types to a specific command by defining a new `cl-defmethod'
-matching this command. Predicate for type in new `cl-defmethod' should
-satisfy `cl-typep' otherwise the new type should be defined with
-`cl-deftype'."
- ;; Call register--type against the register value.
- (register--type (if (consp (cdr register))
- (cadr register)
- (cdr register))))
-
-(cl-defgeneric register--type (regval)
- "Returns type of register value REGVAL."
- (ignore regval))
-
-(cl-defmethod register--type ((_regval string)) 'string)
-(cl-defmethod register--type ((_regval number)) 'number)
-(cl-defmethod register--type ((_regval marker)) 'marker)
-(cl-defmethod register--type ((_regval (eql 'buffer))) 'buffer)
-(cl-defmethod register--type ((_regval (eql 'file))) 'file)
-(cl-defmethod register--type ((_regval (eql 'file-query))) 'file-query)
-(cl-defmethod register--type ((_regval window-configuration)) 'window)
-(cl-deftype frame-register () '(satisfies frameset-register-p))
-(cl-defmethod register--type :extra "frame-register" (_regval) 'frame)
-(cl-deftype kmacro-register () '(satisfies kmacro-register-p))
-(cl-defmethod register--type :extra "kmacro-register" (_regval) 'kmacro)
-
-(defun register-of-type-alist (types)
- "Filter `register-alist' according to TYPES."
- (if (memq 'all types)
- register-alist
- (cl-loop for register in register-alist
- when (memq (register-type register) types)
- collect register)))
-
-(defun register-preview (buffer &optional show-empty types)
+(defun register-preview (buffer &optional show-empty)
"Pop up a window showing the registers preview in BUFFER.
If SHOW-EMPTY is non-nil, show the window even if no registers.
-Argument TYPES (a list) specify the types of register to show, when nil show all
-registers, see `register-type' for suitable types.
Format of each entry is controlled by the variable `register-preview-function'."
- (let ((registers (register-of-type-alist (or types '(all)))))
- (when (or show-empty (consp registers))
- (with-current-buffer-window
- buffer
- (cons 'display-buffer-below-selected
- '((window-height . fit-window-to-buffer)
- (preserve-size . (nil . t))))
- nil
- (with-current-buffer standard-output
- (setq cursor-in-non-selected-windows nil)
- (mapc (lambda (elem)
- (when (get-register (car elem))
- (insert (funcall register-preview-function elem))))
- registers))))))
-
-(cl-defgeneric register-preview-get-defaults (action)
- "Returns default registers according to ACTION."
- (ignore action))
-(cl-defmethod register-preview-get-defaults ((_action (eql set)))
- (cl-loop for s in register-preview-default-keys
- unless (assoc (string-to-char s) register-alist)
- collect s))
+ (when (or show-empty (consp register-alist))
+ (with-current-buffer-window
+ buffer
+ (cons 'display-buffer-below-selected
+ '((window-height . fit-window-to-buffer)
+ (preserve-size . (nil . t))))
+ nil
+ (with-current-buffer standard-output
+ (setq cursor-in-non-selected-windows nil)
+ (mapc (lambda (elem)
+ (when (get-register (car elem))
+ (insert (funcall register-preview-function elem))))
+ register-alist)))))
(defun register-read-with-preview (prompt)
"Read and return a register name, possibly showing existing registers.
-Prompt with the string PROMPT.
+Prompt with the string PROMPT. If `register-alist' and
+`register-preview-delay' are both non-nil, display a window
+listing existing registers after `register-preview-delay' seconds.
If `help-char' (or a member of `help-event-list') is pressed,
display such a window regardless."
(let* ((buffer "*Register Preview*")
- (pat "")
- (map (let ((m (make-sparse-keymap)))
- (set-keymap-parent m minibuffer-local-map)
- m))
- (data (register-command-info this-command))
- types msg result timer act win strs smatch)
- (if data
- (setq types (register-preview-info-types data)
- msg (register-preview-info-msg data)
- act (register-preview-info-act data)
- smatch (register-preview-info-smatch data))
- (setq types '(all)
- msg "Overwrite register `%s'"
- act 'set))
- (setq strs (mapcar (lambda (x)
- (string (car x)))
- (register-of-type-alist types)))
- (when (and (memq act '(insert jump view)) (null strs))
- (error "No register suitable for `%s'" act))
- (dolist (k (cons help-char help-event-list))
- (define-key map
- (vector k) (lambda ()
- (interactive)
- (unless (get-buffer-window buffer)
- (with-selected-window (minibuffer-selected-window)
- (register-preview buffer 'show-empty types))))))
- (define-key map (kbd "<down>") 'register-preview-next)
- (define-key map (kbd "<up>") 'register-preview-previous)
- (define-key map (kbd "C-n") 'register-preview-next)
- (define-key map (kbd "C-p") 'register-preview-previous)
- (unless (or executing-kbd-macro (null register-use-preview))
- (register-preview buffer nil types))
+ (timer (when (numberp register-preview-delay)
+ (run-with-timer register-preview-delay nil
+ (lambda ()
+ (unless (get-buffer-window buffer)
+ (register-preview buffer))))))
+ (help-chars (cl-loop for c in (cons help-char help-event-list)
+ when (not (get-register c))
+ collect c)))
(unwind-protect
- (progn
- (minibuffer-with-setup-hook
- (lambda ()
- (setq timer
- (run-with-idle-timer
- 0.01 'repeat
- (lambda ()
- (with-selected-window (minibuffer-window)
- (let ((input (minibuffer-contents)))
- (when (> (length input) 1)
- (let ((new (substring input 1))
- (old (substring input 0 1)))
- (setq input (if (or (null smatch)
- (member new strs))
- new old))
- (delete-minibuffer-contents)
- (insert input)))
- (when (and smatch (not (string= input ""))
- (not (member input strs)))
- (setq input "")
- (delete-minibuffer-contents)
- (minibuffer-message "Not matching"))
- (when (not (string= input pat))
- (setq pat input))))
- (if (setq win (get-buffer-window buffer))
- (with-selected-window win
- (let ((ov (make-overlay (point-min) (point-min))))
- (goto-char (point-min))
- (remove-overlays)
- (unless (string= pat "")
- (if (re-search-forward (concat "^" pat) nil t)
- (progn (move-overlay
- ov
- (match-beginning 0) (pos-eol))
- (overlay-put ov 'face 'match)
- (when msg
- (with-selected-window (minibuffer-window)
- (minibuffer-message msg pat))))
- (with-selected-window (minibuffer-window)
- (minibuffer-message
- "Register `%s' is empty" pat))))))
- (unless (string= pat "")
- (if (member pat strs)
- (with-selected-window (minibuffer-window)
- (minibuffer-message msg pat))
- (with-selected-window (minibuffer-window)
- (minibuffer-message
- "Register `%s' is empty" pat)))))))))
- (setq result (read-from-minibuffer
- prompt nil map nil nil (register-preview-get-defaults act))))
- (cl-assert (and result (not (string= result "")))
- nil "No register specified")
- (string-to-char result))
- (when timer (cancel-timer timer))
+ (progn
+ (while (memq (read-key (propertize prompt 'face 'minibuffer-prompt))
+ help-chars)
+ (unless (get-buffer-window buffer)
+ (register-preview buffer 'show-empty)))
+ (when (or (eq ?\C-g last-input-event)
+ (eq 'escape last-input-event)
+ (eq ?\C-\[ last-input-event))
+ (keyboard-quit))
+ (if (characterp last-input-event) last-input-event
+ (error "Non-character input-event")))
+ (and (timerp timer) (cancel-timer timer))
(let ((w (get-buffer-window buffer)))
(and (window-live-p w) (delete-window w)))
(and (get-buffer buffer) (kill-buffer buffer)))))
projects / emacs.git / commitdiff