selector.el

   1 ;; -*- mode: emacs-lisp -*-
   2
   3 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   4 ;; This program is free software; you can redistribute it and/or         ;;
   5 ;; modify it under the terms of the GNU General Public License as        ;;
   6 ;; published by the Free Software Foundation; either version 3, or (at   ;;
   7 ;; your option) any later version.                                       ;;
   8 ;;                                                                       ;;
   9 ;; This program is distributed in the hope that it will be useful, but   ;;
  10 ;; WITHOUT ANY WARRANTY; without even the implied warranty of            ;;
  11 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU      ;;
  12 ;; General Public License for more details.                              ;;
  13 ;;                                                                       ;;
  14 ;; You should have received a copy of the GNU General Public License     ;;
  15 ;; along with this program. If not, see <http://www.gnu.org/licenses/>.  ;;
  16 ;;                                                                       ;;
  17 ;; Written by and Copyright (C) Francois Fleuret                         ;;
  18 ;; Contact <francois@fleuret.org> for comments & bug reports             ;;
  19 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  20
  21 ;; The selector/select function provides a simple interface for
  22 ;; selecting an object with on-the-fly pattern matching in a standard
  23 ;; buffer (i.e. not in the minibuffer). You can either use it in your
  24 ;; own functions or directly use selector/quick-pick-recent,
  25 ;; selector/quick-move-in-buffer, or selector/switch-buffer
  26 ;;
  27 ;; For instance, you can add in your .emacs.el
  28 ;;
  29 ;; (require 'recentf)
  30 ;; (recentf-mode 1)
  31 ;;
  32 ;; (when (load "selector" t t)
  33 ;;   (define-key global-map [(control x) (control r)] 'selector/quick-pick-recent)
  34 ;;   (define-key global-map [(control c) (control s)] 'selector/quick-move-in-buffer)
  35 ;;   (define-key global-map [(control x) (control b)] 'selector/switch-buffer)
  36 ;; )
  37
  38 (defgroup selector ()
  39   "Major mode for selection of entries with dynamic pattern matching"
  40   :version "1.2.3")
  41
  42 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  43 ;; User-configurable variables
  44 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  45
  46 (defcustom selector/memorize-entry-only-on-motions t
  47   "If non-nil, only the cursor motions memorize the current selection.
  48 Restriction of the selection does not. This means that if you
  49 change the pattern and then edit it to cancel the change, the
  50 cursor will come back to its original location, unless you have
  51 explicitely moved it with the arrow keys at some point."
  52   :type 'bool
  53   :group 'selector)
  54
  55 (defcustom selector/info-in-mode-line nil
  56   "If nil, the pattern is shown in the menu header.
  57 Otherwise use the mode-line."
  58   :type 'bool
  59   :group 'selector)
  60
  61 (defcustom selector/always-create-buffer nil
  62   "If nil, re-use existing similar buffer when possible."
  63   :type 'bool
  64   :group 'selector)
  65
  66 (defcustom selector/add-to-file-name-history t
  67   "If non-nil, file selected with selector/quick-pick-recent will be added to the mini-buffer filename history."
  68   :type 'bool
  69   :group 'selector)
  70
  71 (defcustom selector/mode-hook nil
  72   "Hook called at the end of the selector mode initialization."
  73   :type 'hook
  74   :group 'selector)
  75
  76 (defcustom selector/quick-pick-recent-filter nil
  77   "Regexp specifying which filenames should be hidden by `selector/quick-pick-recent'"
  78   :type 'string
  79   :group 'selector)
  80
  81 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  82
  83 (defface selector/selection
  84   ;; '((t (:bold t)))
  85   '((t (:background "chartreuse")))
  86   "The face for the current selection.")
  87
  88 (defface selector/dim
  89   '((t (:foreground "gray70")))
  90   "The face for dimmed entries.")
  91
  92 (defface selector/date
  93   '((t (:foreground "dark violet")))
  94   "The face for the dates in selector/quick-pick-recent.")
  95
  96 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  97
  98 (defvar selector/pattern
  99   ""
 100   "The pattern to match to appear in the selector buffer.")
 101
 102 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 103
 104 (defun selector/string-match-all (regexps string)
 105   "Return if STRING matches all regular expressions in REGEXPS."
 106   (if regexps
 107       (and (string-match (car regexps) string)
 108            (selector/string-match-all (cdr regexps) string))
 109     t))
 110
 111 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 112
 113 (defun selector/move-highlight-overlay ()
 114   "Move the highlight overlay to highlight the current line."
 115   (if (get-text-property (point) 'entry)
 116       (move-overlay selector/highlight-overlay
 117                     (or (previous-single-property-change (1+ (point)) 'entry)
 118                         (point-min))
 119                     (or (next-single-property-change (point) 'entry)
 120                         (point-max)))
 121     ;; (move-overlay selector/highlight-overlay 0 0)
 122     (delete-overlay selector/highlight-overlay)
 123     )
 124
 125   (unless (and selector/memorize-entry-only-on-motions
 126                (memq this-command
 127                      '(selector/delete-backward-char
 128                        selector/self-insert-command)))
 129     (setq selector/current-entry (get-text-property (point) 'entry)))
 130   )
 131
 132 (defun selector/refresh ()
 133   "Erase and reconstruct the content of the current buffer
 134 according to `selector/entries' and `selector/pattern'."
 135
 136   (let ((inhibit-read-only t)
 137         (pos (point))
 138         (line-beginning (line-beginning-position))
 139         (regexps (mapcar 'regexp-quote (split-string selector/pattern ";")))
 140         (newpos (point))
 141         (nb-shown-entries 0))
 142
 143     (erase-buffer)
 144
 145     (mapc (lambda (s)
 146             (when (selector/string-match-all regexps (car s))
 147               (setq nb-shown-entries (1+ nb-shown-entries))
 148               (if (eq (cdr s) selector/current-entry)
 149                   (setq newpos (+ (- pos line-beginning) (point))))
 150               (insert
 151                (propertize (concat (car s) "\n")
 152                            'entry (cdr s)
 153                            ;; 'face 'compilation-error
 154                            ))))
 155           selector/entries)
 156
 157     (setq newpos (min newpos (point-max)))
 158     (setq selector/nb-shown-entries (number-to-string nb-shown-entries))
 159
 160     (goto-char (or (and (get-text-property newpos 'entry) newpos)
 161                    (previous-single-property-change newpos 'entry)
 162                    (point-max)))
 163
 164     (beginning-of-line)
 165     (force-mode-line-update)
 166     ))
 167
 168 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 169
 170 (defun selector/self-insert-command ()
 171   "Insert the last pressed key at the end of `selector/pattern'."
 172   (interactive)
 173   (setq selector/pattern (concat selector/pattern
 174                                  (this-command-keys)))
 175   (selector/refresh)
 176   )
 177
 178 (defun selector/delete-backward-char ()
 179   "Remove the last character of `selector/pattern'."
 180   (interactive)
 181   (when (> (length selector/pattern) 0)
 182     (setq selector/pattern (substring selector/pattern 0 -1)))
 183   (selector/refresh)
 184   )
 185
 186 (defun selector/kill-line ()
 187   "Move the content of `selector/pattern' to the kill ring."
 188   (interactive)
 189   (kill-new selector/pattern t)
 190   (setq selector/pattern "")
 191   (selector/refresh))
 192
 193 (defun selector/yank (&optional arg)
 194   "Append the content of the kill ring to `selector/pattern'."
 195   (interactive "P")
 196   (setq selector/pattern (concat selector/pattern
 197                                  (current-kill (cond
 198                                                 ((listp arg) 0)
 199                                                 ((eq arg '-) -2)
 200                                                 (t (1- arg))))))
 201   (selector/refresh))
 202
 203 (defun selector/return ()
 204   "Call the function specified by `selector/callback' with the
 205 entry at point as parameter."
 206   (interactive)
 207   (let ((result (get-text-property (point) 'entry))
 208         (callback selector/callback))
 209     (kill-this-buffer)
 210     (if result (funcall callback result)
 211       (error "No selection"))))
 212
 213 (defun selector/goto-next-entry ()
 214   "Move point to the next entry."
 215   (interactive)
 216   (let ((n (or (next-single-property-change (point) 'entry)
 217                (point-min))))
 218     (if n (goto-char n))))
 219
 220 (defun selector/goto-previous-entry ()
 221   "Move point to the previous entry."
 222   (interactive)
 223   (let ((n (or (previous-single-property-change (point) 'entry)
 224                (previous-single-property-change (point-max) 'entry))))
 225     (if n (goto-char n))))
 226
 227 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 228
 229 (defun selector/mode ()
 230   "Mode for selection of strings. See `selector/select' for a
 231 detailed explanation."
 232
 233   (unless (boundp 'selector/map)
 234     (setq selector/map (make-sparse-keymap))
 235
 236     (mapc (lambda (p)
 237             (substitute-key-definition (car p)
 238                                        (cdr p)
 239                                        selector/map global-map)
 240             )
 241
 242           ;; What are the functions to substitute by what
 243           '((self-insert-command . selector/self-insert-command)
 244             (delete-backward-char . selector/delete-backward-char)
 245             (kill-line . selector/kill-line)
 246             (yank . selector/yank)
 247             (newline . selector/return)
 248             ;; (keyboard-quit . kill-this-buffer)
 249             ))
 250
 251     (define-key selector/map "\C-g"
 252       'kill-this-buffer)
 253
 254     (define-key selector/map (kbd "TAB")
 255       'selector/goto-next-entry)
 256
 257     (define-key selector/map [(shift iso-lefttab)]
 258       'selector/goto-previous-entry)
 259
 260     )
 261
 262   (setq major-mode 'selector/mode
 263         mode-name "Selector"
 264         buffer-read-only t
 265         )
 266
 267   (set
 268    (if selector/info-in-mode-line 'mode-line-format 'header-line-format)
 269    '(" " selector/nb-shown-entries "/"
 270      selector/nb-total-entries " pattern: " selector/pattern)
 271    )
 272
 273   (buffer-disable-undo)
 274   (use-local-map selector/map)
 275   (run-hooks 'selector/mode-hook)
 276   )
 277
 278 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 279
 280 (defun selector/select (entries callback &optional name)
 281   "Open a new buffer showing dynamically a subset of entries
 282 matching a pattern that can be changed by pressing the usual
 283 \"insertable\" symbols or backspace. Pressing the enter key
 284 validates the selection.
 285
 286 Note that the pattern is not a regexp but a series of substrings
 287 separated by `;'s that have all to be present.
 288
 289 The key mapping is hacked so that the keys associated to
 290 `self-insert-command', `delete-backward-char', `kill-line',
 291 `yank' and `newline' are associated to functions which do somehow
 292 what they are supposed to do. The latter validating the
 293 selection.
 294
 295 ENTRIES is a list of cons cells, each composed of a string to
 296 display and an object to pass as the unique parameter to CALLBACK
 297 when the user actually does a selection. The optional NAME
 298 parameter specifies the name to give to the buffer.
 299
 300 Setting `selector/memorize-entry-only-on-motions' to non-nil
 301 means that the entry to keep the cursor on when changing the
 302 selection is set only on cursor motions. To show the pattern in
 303 the modeline set `selector/info-in-mode-line'. The header line is
 304 used by default. To always open a new buffer and not re-use an
 305 existing buffer with the same name, set
 306 `selector/always-create-buffer' to non-nil.
 307
 308 There seems to be header-line refreshing problems with emacs21."
 309
 310   (switch-to-buffer
 311    (get-buffer-create
 312     (funcall
 313      (if selector/always-create-buffer 'generate-new-buffer-name 'identity)
 314      (or name "*selector*"))))
 315
 316   (set (make-local-variable 'selector/entries) entries)
 317   (set (make-local-variable 'selector/callback) callback)
 318   (set (make-local-variable 'selector/pattern) "")
 319   (set (make-local-variable 'selector/highlight-overlay) (make-overlay 0 0))
 320   (set (make-local-variable 'selector/current-entry) nil)
 321   (set (make-local-variable 'selector/nb-total-entries)
 322        (number-to-string (length entries)))
 323   (set (make-local-variable 'selector/nb-shown-entries) "?")
 324
 325   (overlay-put selector/highlight-overlay 'face 'selector/selection)
 326
 327   (add-hook 'post-command-hook 'selector/move-highlight-overlay nil t)
 328   (selector/mode)
 329   (selector/refresh)
 330   )
 331
 332 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 333 ;; To open recent files
 334 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 335
 336 (defun selector/filename-to-string (filename)
 337   "Generate the line associated to a filename for `selector/quick-pick-recent'"
 338   (concat
 339    " "
 340    (if (file-remote-p s)
 341        "          "
 342      (propertize
 343       (format-time-string   "%b %a %e" (elt (file-attributes s) 5))
 344       'face 'selector/date))
 345
 346    ;; " -- "
 347
 348    " "
 349
 350    (if (string-match abbreviated-home-dir s)
 351        (concat (propertize
 352                 (substring s 0 (match-end 0)) 'face 'selector/dim)
 353                (substring s (match-end 0)))
 354      s)
 355
 356    ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 357    ;; (if (and (boundp 'selector/previous-filename) selector/previous-filename)
 358    ;;     (let ((l (abs (compare-strings
 359    ;;                    selector/previous-filename nil nil
 360    ;;                    filename nil nil))))
 361    ;;       ;; (if (> l 0) (setq l
 362    ;;       (setq selector/previous-filename filename)
 363    ;;       (concat (propertize
 364    ;;                (substring s 0 l) 'face 'selector/dim)
 365    ;;               (substring s l))
 366    ;;       )
 367    ;;   filename
 368    ;;   )
 369    ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 370
 371    )
 372   )
 373
 374 (defun selector/find-file (filename)
 375   (if selector/add-to-file-name-history
 376       (add-to-history 'file-name-history
 377                       (replace-regexp-in-string
 378                        abbreviated-home-dir "~/" filename)
 379                       )
 380     )
 381
 382   (find-file filename))
 383
 384 (defun selector/pick-file (filename)
 385   "Callback function for `selector/quick-pick-recent'. When
 386 called with a universal argument, allows the user to edit the
 387 filename."
 388   (interactive)
 389   (if current-prefix-arg
 390       (selector/find-file (read-file-name
 391                            "Find file: "
 392                            (file-name-directory filename)
 393                            nil
 394                            nil
 395                            (file-name-nondirectory filename)))
 396     (selector/find-file filename)))
 397
 398 (defun selector/quick-pick-recent (universal)
 399   "Open a file picked in `recentf-list' with the dynamic
 400 pattern-matching search implemented in `selector/select'.
 401
 402 Without a prefix argument, hide files matching
 403 `selector/quick-pick-recent-filter'.
 404
 405 With a prefix argument before the selection of the file per se,
 406 permits to edit it before opening."
 407   (interactive "P")
 408
 409   (unless (and (boundp recentf-mode) recentf-mode)
 410     (error "recentf mode must be turned on"))
 411
 412   (let ((l
 413          (mapcar
 414           (lambda (s) (cons (selector/filename-to-string s) s))
 415           (if (and (not universal) selector/quick-pick-recent-filter)
 416               (delq nil
 417                     (mapcar
 418                      (lambda (x) (and (not (string-match selector/quick-pick-recent-filter x)) x))
 419                      recentf-list)
 420                     )
 421             recentf-list
 422             )
 423           )
 424          ))
 425
 426     (selector/select
 427      l
 428      'selector/pick-file
 429      "*selector find-file*"
 430      ))
 431   )
 432
 433 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 434 ;; To search in the current buffer
 435 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 436
 437 (defun selector/quick-move-in-buffer ()
 438   "Move the cursor in the current buffer to a line selected
 439 dynamically with `selector/select'."
 440   (interactive)
 441   (selector/select
 442    (reverse
 443     (let ((l nil))
 444       (save-excursion
 445         (goto-char (point-min))
 446         (while (< (point) (point-max))
 447           (setq l (cons (cons (buffer-substring (point-at-bol) (point-at-eol))
 448                               (point-at-bol)) l))
 449           (forward-line 1))
 450         l))
 451     )
 452    'goto-char
 453    "*selector buffer move*"
 454    ))
 455
 456 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 457 ;; To switch between buffers
 458 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 459
 460 (defun selector/switch-buffer () (interactive)
 461   "Select the current buffer dynamically with `selector/select'."
 462   (interactive)
 463   (selector/select
 464    (let ((l nil))
 465      (mapc
 466       (lambda (buffer)
 467         (with-current-buffer buffer
 468           (let ((name (buffer-name))
 469                 (size (buffer-size))
 470                 (file (buffer-file-name))
 471                 (modified (buffer-modified-p)))
 472             (when (not (string-match "^ +" name))
 473               (push
 474                (cons
 475                 (replace-regexp-in-string
 476                  " +$"
 477                  ""
 478                  (format
 479                   "% 8d %s %-30s%s"
 480                   size
 481                   (if modified "*" "-")
 482                   name
 483                   (if file (concat
 484                             (replace-regexp-in-string abbreviated-home-dir
 485                                                       "~/" file)
 486                             ) "")
 487                   ))
 488                 buffer)
 489                l)
 490               ))))
 491       (reverse (buffer-list)))
 492      l)
 493    'switch-to-buffer
 494    "*selector switch-buffer*"
 495    ))
 496
 497 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 498 ;; To search among sentences (i.e. between periods, not between \n)
 499 ;; This is work in progress, it currently looks kind of ugly but is
 500 ;; already useful to navigate in a long article
 501 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 502
 503 (defun selector/search-sentence ()
 504   "Move the cursor to a sentence chosen dynamically with
 505 `selector/select'."
 506   (interactive)
 507   (selector/select
 508    (let ((sentences nil))
 509      (save-excursion
 510        (goto-char (point-min))
 511        (while (re-search-forward "[^.]+\\." nil t)
 512          (let ((s (replace-regexp-in-string "^[ \n]+" ""
 513                                             (match-string-no-properties 0)))
 514                (p (match-beginning 0)))
 515            (setq s (replace-regexp-in-string "[ \n]+$" "" s))
 516            (when (> (length s) 1)
 517              (push (cons
 518                     (with-temp-buffer
 519                       (insert s "\n")
 520                       (fill-region (point-min) (point-max))
 521                       (buffer-string))
 522                     p) sentences)))))
 523      (reverse sentences))
 524    'goto-char))
 525
 526 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 527
 528 (defface selector/dir
 529   '((t (:foreground "red")))
 530   "The face for directories.")
 531
 532 (defface selector/symlink
 533   '((t (:foreground "blue")))
 534   "The face for symlinks.")
 535
 536 (defun selector/rec-find-file (&optional filename) (interactive)
 537   (setq filename (or filename
 538                      (and (buffer-file-name) (file-name-directory (buffer-file-name)))
 539                      default-directory))
 540
 541   (if (file-regular-p filename) (find-file filename)
 542     (selector/select
 543      (mapcar
 544       (lambda (file)
 545         (let ((f (car file)))
 546           (cons
 547            (if (file-regular-p f)
 548                f
 549              (if (file-symlink-p f)
 550                  (propertize f 'face 'selector/symlink)
 551                (propertize f 'face 'selector/dir)))
 552            (concat filename "/" f))))
 553       (directory-files-and-attributes filename))
 554      'selector/rec-find-file
 555      (concat "selector " filename)
 556      )))
 557
 558 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;