unofficial mirror of emacs-devel@gnu.org 
 help / color / mirror / code / Atom feed
* A dynamic pattern-matching
@ 2009-03-03  8:23 Francois Fleuret
  2009-03-03 19:16 ` Stefan Monnier
  0 siblings, 1 reply; 5+ messages in thread
From: Francois Fleuret @ 2009-03-03  8:23 UTC (permalink / raw)
  To: emacs-devel

[-- Attachment #1: message body and .signature --]
[-- Type: text/plain, Size: 806 bytes --]

Dear Emacs developers,

I wrote a dynamic pattern-matching that restricts in real-time the
display of a list of items to the ones matching the typed
pattern. Since it uses a standard buffer it shows the said list over a
large visual space, which is very practical.

Among other things, it provides an efficient way of visiting a file
picked in recentf-list.

To try it, you just need the file selector.el attached and something
like this in your ~/.emacs.el

(when (load "selector" t)
  (define-key global-map [(control x) (control b)] 'selector/switch-buffer)
  (define-key global-map [(control x) (control q)] 'selector/quick-pick-recent)
  )

As far as I could test, it works with emacs21, emacs22 and emacs CVS.

Regards,

-- 
Francois Fleuret                            http://www.idiap.ch/~fleuret/


[-- Attachment #2: selector.el --]
[-- Type: application/octet-stream, Size: 17457 bytes --]

;; -*- mode: emacs-lisp -*-

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; This program is free software; you can redistribute it and/or         ;;
;; modify it under the terms of the GNU General Public License as        ;;
;; published by the Free Software Foundation; either version 3, or (at   ;;
;; your option) any later version.                                       ;;
;;                                                                       ;;
;; This program is distributed in the hope that it will be useful, but   ;;
;; WITHOUT ANY WARRANTY; without even the implied warranty of            ;;
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU      ;;
;; General Public License for more details.                              ;;
;;                                                                       ;;
;; You should have received a copy of the GNU General Public License     ;;
;; along with this program. If not, see <http://www.gnu.org/licenses/>.  ;;
;;                                                                       ;;
;; Written by and Copyright (C) Francois Fleuret                         ;;
;; Contact <francois@fleuret.org> for comments & bug reports             ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; The selector/select function provides a simple interface for
;; selecting an object with on-the-fly pattern matching in a standard
;; buffer (i.e. not in the minibuffer). You can either use it in your
;; own functions or directly use selector/quick-pick-recent or
;; selector/quick-move-in-buffer.
;;
;; For instance, you can add in your .emacs.el
;;
;; (require 'recentf)
;; (recentf-mode 1)
;;
;; (when (load "selector" t t)
;;   (define-key global-map [(control x) (control r)] 'selector/quick-pick-recent)
;;   (define-key global-map [(control c) (control s)] 'selector/quick-move-in-buffer)
;;   (define-key global-map [(control x) (control b)] 'selector/switch-buffer)
;; )

(defgroup selector ()
  "Major mode for selection of entries with dynamic pattern matching"
  :version "1.2.3")

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; User-configurable variables
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defcustom selector/memorize-entry-only-on-motions t
  "If non-nil, only the cursor motions memorize the current selection.
Restriction of the selection does not. This means that if you
change the pattern and then edit it to cancel the change, the
cursor will come back to its original location, unless you have
explicitely moved it with the arrow keys at some point."
  :type 'bool
  :group 'selector)

(defcustom selector/info-in-mode-line nil
  "If nil, the pattern is shown in the menu header.
Otherwise use the mode-line."
  :type 'bool
  :group 'selector)

(defcustom selector/always-create-buffer nil
  "If nil, re-use existing similar buffer when possible."
  :type 'bool
  :group 'selector)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defface selector/selection
  ;; '((t (:bold t)))
  '((t (:background "chartreuse")))
  "The face for the current selection.")

(defface selector/dim
  '((t (:foreground "gray70")))
  "The face for dimmed entries.")

(defface selector/date
  '((t (:foreground "dark violet")))
  "The face for the dates in selector/quick-pick-recent.")

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defvar selector/pattern
  ""
  "The pattern to match to appear in the selector buffer.")

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun selector/string-match-all (regexps string)
  "Return if STRING matches all regular expressions in REGEXPS."
  (if regexps
      (and (string-match (car regexps) string)
           (selector/string-match-all (cdr regexps) string))
    t))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun selector/move-highlight-overlay ()
  "Move the highlight overlay to highlight the current line."
  (if (get-text-property (point) 'entry)
      (move-overlay selector/highlight-overlay
                    (or (previous-single-property-change (1+ (point)) 'entry)
                        (point-min))
                    (or (next-single-property-change (point) 'entry)
                        (point-max)))
    (move-overlay selector/highlight-overlay 0 0)
    )

  (unless (and selector/memorize-entry-only-on-motions
               (memq this-command
                     '(selector/delete-backward-char
                       selector/self-insert-command)))
    (setq selector/current-entry (get-text-property (point) 'entry)))
  )

(defun selector/refresh ()
  "Erase and reconstruct the content of the current buffer
according to `selector/entries' and `selector/pattern'."

  (let ((inhibit-read-only t)
        (pos (point))
        (line-beginning (line-beginning-position))
        (regexps (mapcar 'regexp-quote (split-string selector/pattern ";")))
        (newpos (point))
        (nb-shown-entries 0))

    (erase-buffer)

    (mapc (lambda (s)
            (when (selector/string-match-all regexps (car s))
              (setq nb-shown-entries (1+ nb-shown-entries))
              (if (eq (cdr s) selector/current-entry)
                  (setq newpos (+ (- pos line-beginning) (point))))
              (insert
               (propertize (concat (car s) "\n")
                           'entry (cdr s)
                           ;; 'face 'compilation-error
                           ))))
          selector/entries)

    (setq newpos (min newpos (point-max)))
    (setq selector/nb-shown-entries (number-to-string nb-shown-entries))

    (goto-char (or (and (get-text-property newpos 'entry) newpos)
                   (previous-single-property-change newpos 'entry)
                   (point-max)))

    (beginning-of-line)
    (force-mode-line-update)
    ))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun selector/self-insert-command ()
  "Insert the last pressed key at the end of `selector/pattern'."
  (interactive)
  (setq selector/pattern (concat selector/pattern
                                 (this-command-keys)))
  (selector/refresh)
  )

(defun selector/delete-backward-char ()
  "Remove the last character of `selector/pattern'."
  (interactive)
  (when (> (length selector/pattern) 0)
    (setq selector/pattern (substring selector/pattern 0 -1)))
  (selector/refresh)
  )

(defun selector/kill-line ()
  "Move the content of `selector/pattern' to the kill ring."
  (interactive)
  (kill-new selector/pattern t)
  (setq selector/pattern "")
  (selector/refresh))

(defun selector/yank (&optional arg)
  "Append the content of the kill ring to `selector/pattern'."
  (interactive "P")
  (setq selector/pattern (concat selector/pattern
                                 (current-kill (cond
                                                ((listp arg) 0)
                                                ((eq arg '-) -2)
                                                (t (1- arg))))))
  (selector/refresh))

(defun selector/return ()
  "Call the function specified by `selector/callback' with the
entry at point as parameter."
  (interactive)
  (let ((result (get-text-property (point) 'entry))
        (callback selector/callback))
    (kill-this-buffer)
    (if result (funcall callback result)
      (error "No selection"))))

(defun selector/goto-next-entry ()
  "Move point to the next entry."
  (interactive)
  (let ((n (or (next-single-property-change (point) 'entry)
               (point-min))))
    (if n (goto-char n))))

(defun selector/goto-previous-entry ()
  "Move point to the previous entry."
  (interactive)
  (let ((n (or (previous-single-property-change (point) 'entry)
               (previous-single-property-change (point-max) 'entry))))
    (if n (goto-char n))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun selector/mode ()
  "Mode for selection of strings. See `selector/select' for a
detailed explanation."

  (unless (boundp 'selector/map)
    (setq selector/map (make-sparse-keymap))

    (mapc (lambda (p)
            (substitute-key-definition (car p)
                                       (cdr p)
                                       selector/map global-map)
            )

          ;; What are the functions to substitute by what
          '((self-insert-command . selector/self-insert-command)
            (delete-backward-char . selector/delete-backward-char)
            (kill-line . selector/kill-line)
            (yank . selector/yank)
            (newline . selector/return)
            ;; (keyboard-quit . kill-this-buffer)
            ))

    (define-key selector/map "\C-g"
      'kill-this-buffer)

    (define-key selector/map (kbd "TAB")
      'selector/goto-next-entry)

    (define-key selector/map [(shift iso-lefttab)]
      'selector/goto-previous-entry)

    )

  (setq major-mode 'selector/mode
        mode-name "Selector"
        buffer-read-only t
        )

  (set
   (if selector/info-in-mode-line 'mode-line-format 'header-line-format)
   '(" " selector/nb-shown-entries "/"
     selector/nb-total-entries " pattern: " selector/pattern)
   )

  (buffer-disable-undo)
  (use-local-map selector/map)
  )

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun selector/select (entries callback &optional name)
  "Open a new buffer showing dynamically a subset of entries
matching a pattern that can be changed by pressing the usual
\"insertable\" symbols or backspace. Pressing the enter key
validates the selection.

Note that the pattern is not a regexp but a series of substrings
separated by `;'s that have all to be present.

The key mapping is hacked so that the keys associated to
`self-insert-command', `delete-backward-char', `kill-line',
`yank' and `newline' are associated to functions which do somehow
what they are supposed to do. The latter validating the
selection.

ENTRIES is a list of cons cells, each composed of a string to
display and an object to pass as the unique parameter to CALLBACK
when the user actually does a selection. The optional NAME
parameter specifies the name to give to the buffer.

Setting `selector/memorize-entry-only-on-motions' to non-nil
means that the entry to keep the cursor on when changing the
selection is set only on cursor motions. To show the pattern in
the modeline set `selector/info-in-mode-line'. The header line is
used by default. To always open a new buffer and not re-use an
existing buffer with the same name, set
`selector/always-create-buffer' to non-nil.

There seems to be header-line refreshing problems with emacs21."

  (switch-to-buffer
   (get-buffer-create
    (funcall
     (if selector/always-create-buffer 'generate-new-buffer-name 'identity)
     (or name "*selector*"))))

  (set (make-local-variable 'selector/entries) entries)
  (set (make-local-variable 'selector/callback) callback)
  (set (make-local-variable 'selector/pattern) "")
  (set (make-local-variable 'selector/highlight-overlay) (make-overlay 0 0))
  (set (make-local-variable 'selector/current-entry) nil)
  (set (make-local-variable 'selector/nb-total-entries)
       (number-to-string (length entries)))
  (set (make-local-variable 'selector/nb-shown-entries) "?")

  (overlay-put selector/highlight-overlay 'face 'selector/selection)

  (add-hook 'post-command-hook 'selector/move-highlight-overlay nil t)
  (selector/mode)
  (selector/refresh)
  )

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; To open recent files
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun selector/filename-to-string (filename)
  "Generate the line associated to a filename for `selector/quick-pick-recent'"
  (concat
   " "
   (if (file-remote-p s)
       "          "
     (propertize
      (format-time-string   "%a %b %e" (elt (file-attributes s) 5))
      'face 'selector/date))

   " -- "

   (if (string-match abbreviated-home-dir s)
       (concat (propertize
                (substring s 0 (match-end 0)) 'face 'selector/dim)
               (substring s (match-end 0)))
     s)
   )
  )

(defun selector/find-file (filename)
  "Callback function for `selector/quick-pick-recent'. When
called with a universal argument, allows the user to edit the
filename."
  (interactive)
  (if current-prefix-arg
      (find-file (read-file-name
                  "Find file: "
                  (file-name-directory filename)
                  nil
                  nil
                  (file-name-nondirectory filename)))
    (find-file filename)))

(defun selector/quick-pick-recent ()
  "Open a file picked in `recentf-list' with the dynamic
pattern-matching search implemented in `selector/select'. With a
prefix argument, allows to edit the filename after selection."
  (interactive)

  (unless (and (boundp recentf-mode) recentf-mode)
    (error "recentf mode must be turned on"))

  (selector/select

   (mapcar
    (lambda (s)
      (cons (selector/filename-to-string s) s))
    recentf-list)

   'selector/find-file
   "*selector find-file*"
   ))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; To search in the current buffer
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun selector/quick-move-in-buffer ()
  "Move the cursor in the current buffer to a line selected
dynamically with `selector/select'."
  (interactive)
  (selector/select
   (reverse
    (let ((l nil))
      (save-excursion
        (goto-char (point-min))
        (while (< (point) (point-max))
          (setq l (cons (cons (buffer-substring (point-at-bol) (point-at-eol))
                              (point-at-bol)) l))
          (forward-line 1))
        l))
    )
   'goto-char
   "*selector buffer move*"
   ))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; To switch between buffers
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun selector/switch-buffer () (interactive)
  "Select the current buffer dynamically with `selector/select'."
  (interactive)
  (selector/select
   (let ((l nil))
     (mapc
      (lambda (buffer)
        (with-current-buffer buffer
          (let ((name (buffer-name))
                (size (buffer-size))
                (file (buffer-file-name))
                (modified (buffer-modified-p)))
            (when (not (string-match "^ +" name))
              (push
               (cons
                (replace-regexp-in-string
                 " +$"
                 ""
                 (format
                  "% 8d %s %-30s%s"
                  size
                  (if modified "*" "-")
                  name
                  (if file (concat
                            (replace-regexp-in-string abbreviated-home-dir
                                                      "~/" file)
                            ) "")
                  ))
                buffer)
               l)
              ))))
      (reverse (buffer-list)))
     l)
   'switch-to-buffer
   "*selector buffer switch*"
   ))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; To search among sentences (i.e. between periods, not between \n)
;; This is work in progress, it currently looks kind of ugly but is
;; already useful to navigate in a long article
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun selector/search-sentence ()
  "Move the cursor to a sentence chosen dynamically with
`selector/select'."
  (interactive)
  (selector/select
   (let ((sentences nil))
     (save-excursion
       (goto-char (point-min))
       (while (re-search-forward "[^.]+\\." nil t)
         (let ((s (replace-regexp-in-string "^[ \n]+" ""
                                            (match-string-no-properties 0)))
               (p (match-beginning 0)))
           (setq s (replace-regexp-in-string "[ \n]+$" "" s))
           (when (> (length s) 1)
             (push (cons
                    (with-temp-buffer
                      (insert s "\n")
                      (fill-region (point-min) (point-max))
                      (buffer-string))
                    p) sentences)))))
     (reverse sentences))
   'goto-char))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defface selector/dir
  '((t (:foreground "red")))
  "The face for directories.")

(defface selector/symlink
  '((t (:foreground "blue")))
  "The face for symlinks.")

(defun selector/rec-find-file (&optional filename) (interactive)
  (setq filename (or filename
                     (and (buffer-file-name) (file-name-directory (buffer-file-name)))
                     default-directory))

  (if (file-regular-p filename) (find-file filename)
    (selector/select
     (mapcar
      (lambda (file)
        (let ((f (car file)))
          (cons
           (if (file-regular-p f)
               f
             (if (file-symlink-p f)
                 (propertize f 'face 'selector/symlink)
               (propertize f 'face 'selector/dir)))
           (concat filename "/" f))))
      (directory-files-and-attributes filename))
     'selector/rec-find-file
     (concat "selector " filename)
     )))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

^ permalink raw reply	[flat|nested] 5+ messages in thread

end of thread, other threads:[~2009-03-04  1:11 UTC | newest]

Thread overview: 5+ messages (download: mbox.gz follow: Atom feed
-- links below jump to the message on this page --
2009-03-03  8:23 A dynamic pattern-matching Francois Fleuret
2009-03-03 19:16 ` Stefan Monnier
2009-03-03 21:33   ` Francois Fleuret
2009-03-04  1:11     ` Stefan Monnier
2009-03-03 21:52   ` Vagn Johansen

Code repositories for project(s) associated with this public inbox

	https://git.savannah.gnu.org/cgit/emacs.git

This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).