;; FIXME: Clean up namespace usage!
+(declare-function frameset-register-p "frameset")
+
(cl-defstruct
(registerv (:constructor nil)
(:constructor registerv--make (&optional data print-func
:type '(choice (const :tag "None" nil)
(character :tag "Use register" :value ?+)))
+;; FIXME: This is no more needed, remove it.
(defcustom register-preview-delay 1
"If non-nil, time to wait in seconds before popping up register preview window.
If nil, do not show register previews, unless `help-char' (or a member of
:type '(choice number (const :tag "No preview unless requested" nil))
:group 'register)
+(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."
(alist-get register register-alist))
Called with one argument, a cons (NAME . CONTENTS) as found in `register-alist'.
The function should return a string, the description of the argument.")
-(defun register-preview (buffer &optional show-empty)
+(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)
"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'."
- (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)))))
+ (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))
(defun register-read-with-preview (prompt)
"Read and return a register name, possibly showing existing registers.
-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.
+Prompt with the string PROMPT.
If `help-char' (or a member of `help-event-list') is pressed,
display such a window regardless."
(let* ((buffer "*Register Preview*")
- (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)))
+ (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))
(unwind-protect
- (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))
+ (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))
(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