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 or
  25 ;; selector/quick-move-in-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/mode-hook nil
  67   "Hook called at the end of the selector mode initialization."
  68   :type 'hook
  69   :group 'selector)
  70
  71 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  72
  73 (defface selector/selection
  74   ;; '((t (:bold t)))
  75   '((t (:background "chartreuse")))
  76   "The face for the current selection.")
  77
  78 (defface selector/dim
  79   '((t (:foreground "gray70")))
  80   "The face for dimmed entries.")
  81
  82 (defface selector/date
  83   '((t (:foreground "dark violet")))
  84   "The face for the dates in selector/quick-pick-recent.")
  85
  86 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  87
  88 (defvar selector/pattern
  89   ""
  90   "The pattern to match to appear in the selector buffer.")
  91
  92 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  93
  94 (defun selector/string-match-all (regexps string)
  95   "Return if STRING matches all regular expressions in REGEXPS."
  96   (if regexps
  97       (and (string-match (car regexps) string)
  98            (selector/string-match-all (cdr regexps) string))
  99     t))
 100
 101 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 102
 103 (defun selector/move-highlight-overlay ()
 104   "Move the highlight overlay to highlight the current line."
 105   (if (get-text-property (point) 'entry)
 106       (move-overlay selector/highlight-overlay
 107                     (or (previous-single-property-change (1+ (point)) 'entry)
 108                         (point-min))
 109                     (or (next-single-property-change (point) 'entry)
 110                         (point-max)))
 111     ;; (move-overlay selector/highlight-overlay 0 0)
 112     (delete-overlay selector/highlight-overlay)
 113     )
 114
 115   (unless (and selector/memorize-entry-only-on-motions
 116                (memq this-command
 117                      '(selector/delete-backward-char
 118                        selector/self-insert-command)))
 119     (setq selector/current-entry (get-text-property (point) 'entry)))
 120   )
 121
 122 (defun selector/refresh ()
 123   "Erase and reconstruct the content of the current buffer
 124 according to `selector/entries' and `selector/pattern'."
 125
 126   (let ((inhibit-read-only t)
 127         (pos (point))
 128         (line-beginning (line-beginning-position))
 129         (regexps (mapcar 'regexp-quote (split-string selector/pattern ";")))
 130         (newpos (point))
 131         (nb-shown-entries 0))
 132
 133     (erase-buffer)
 134
 135     (mapc (lambda (s)
 136             (when (selector/string-match-all regexps (car s))
 137               (setq nb-shown-entries (1+ nb-shown-entries))
 138               (if (eq (cdr s) selector/current-entry)
 139                   (setq newpos (+ (- pos line-beginning) (point))))
 140               (insert
 141                (propertize (concat (car s) "\n")
 142                            'entry (cdr s)
 143                            ;; 'face 'compilation-error
 144                            ))))
 145           selector/entries)
 146
 147     (setq newpos (min newpos (point-max)))
 148     (setq selector/nb-shown-entries (number-to-string nb-shown-entries))
 149
 150     (goto-char (or (and (get-text-property newpos 'entry) newpos)
 151                    (previous-single-property-change newpos 'entry)
 152                    (point-max)))
 153
 154     (beginning-of-line)
 155     (force-mode-line-update)
 156     ))
 157
 158 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 159
 160 (defun selector/self-insert-command ()
 161   "Insert the last pressed key at the end of `selector/pattern'."
 162   (interactive)
 163   (setq selector/pattern (concat selector/pattern
 164                                  (this-command-keys)))
 165   (selector/refresh)
 166   )
 167
 168 (defun selector/delete-backward-char ()
 169   "Remove the last character of `selector/pattern'."
 170   (interactive)
 171   (when (> (length selector/pattern) 0)
 172     (setq selector/pattern (substring selector/pattern 0 -1)))
 173   (selector/refresh)
 174   )
 175
 176 (defun selector/kill-line ()
 177   "Move the content of `selector/pattern' to the kill ring."
 178   (interactive)
 179   (kill-new selector/pattern t)
 180   (setq selector/pattern "")
 181   (selector/refresh))
 182
 183 (defun selector/yank (&optional arg)
 184   "Append the content of the kill ring to `selector/pattern'."
 185   (interactive "P")
 186   (setq selector/pattern (concat selector/pattern
 187                                  (current-kill (cond
 188                                                 ((listp arg) 0)
 189                                                 ((eq arg '-) -2)
 190                                                 (t (1- arg))))))
 191   (selector/refresh))
 192
 193 (defun selector/return ()
 194   "Call the function specified by `selector/callback' with the
 195 entry at point as parameter."
 196   (interactive)
 197   (let ((result (get-text-property (point) 'entry))
 198         (callback selector/callback))
 199     (kill-this-buffer)
 200     (if result (funcall callback result)
 201       (error "No selection"))))
 202
 203 (defun selector/goto-next-entry ()
 204   "Move point to the next entry."
 205   (interactive)
 206   (let ((n (or (next-single-property-change (point) 'entry)
 207                (point-min))))
 208     (if n (goto-char n))))
 209
 210 (defun selector/goto-previous-entry ()
 211   "Move point to the previous entry."
 212   (interactive)
 213   (let ((n (or (previous-single-property-change (point) 'entry)
 214                (previous-single-property-change (point-max) 'entry))))
 215     (if n (goto-char n))))
 216
 217 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 218
 219 (defun selector/mode ()
 220   "Mode for selection of strings. See `selector/select' for a
 221 detailed explanation."
 222
 223   (unless (boundp 'selector/map)
 224     (setq selector/map (make-sparse-keymap))
 225
 226     (mapc (lambda (p)
 227             (substitute-key-definition (car p)
 228                                        (cdr p)
 229                                        selector/map global-map)
 230             )
 231
 232           ;; What are the functions to substitute by what
 233           '((self-insert-command . selector/self-insert-command)
 234             (delete-backward-char . selector/delete-backward-char)
 235             (kill-line . selector/kill-line)
 236             (yank . selector/yank)
 237             (newline . selector/return)
 238             ;; (keyboard-quit . kill-this-buffer)
 239             ))
 240
 241     (define-key selector/map "\C-g"
 242       'kill-this-buffer)
 243
 244     (define-key selector/map (kbd "TAB")
 245       'selector/goto-next-entry)
 246
 247     (define-key selector/map [(shift iso-lefttab)]
 248       'selector/goto-previous-entry)
 249
 250     )
 251
 252   (setq major-mode 'selector/mode
 253         mode-name "Selector"
 254         buffer-read-only t
 255         )
 256
 257   (set
 258    (if selector/info-in-mode-line 'mode-line-format 'header-line-format)
 259    '(" " selector/nb-shown-entries "/"
 260      selector/nb-total-entries " pattern: " selector/pattern)
 261    )
 262
 263   (buffer-disable-undo)
 264   (use-local-map selector/map)
 265   (run-hooks 'selector/mode-hook)
 266   )
 267
 268 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 269
 270 (defun selector/select (entries callback &optional name)
 271   "Open a new buffer showing dynamically a subset of entries
 272 matching a pattern that can be changed by pressing the usual
 273 \"insertable\" symbols or backspace. Pressing the enter key
 274 validates the selection.
 275
 276 Note that the pattern is not a regexp but a series of substrings
 277 separated by `;'s that have all to be present.
 278
 279 The key mapping is hacked so that the keys associated to
 280 `self-insert-command', `delete-backward-char', `kill-line',
 281 `yank' and `newline' are associated to functions which do somehow
 282 what they are supposed to do. The latter validating the
 283 selection.
 284
 285 ENTRIES is a list of cons cells, each composed of a string to
 286 display and an object to pass as the unique parameter to CALLBACK
 287 when the user actually does a selection. The optional NAME
 288 parameter specifies the name to give to the buffer.
 289
 290 Setting `selector/memorize-entry-only-on-motions' to non-nil
 291 means that the entry to keep the cursor on when changing the
 292 selection is set only on cursor motions. To show the pattern in
 293 the modeline set `selector/info-in-mode-line'. The header line is
 294 used by default. To always open a new buffer and not re-use an
 295 existing buffer with the same name, set
 296 `selector/always-create-buffer' to non-nil.
 297
 298 There seems to be header-line refreshing problems with emacs21."
 299
 300   (switch-to-buffer
 301    (get-buffer-create
 302     (funcall
 303      (if selector/always-create-buffer 'generate-new-buffer-name 'identity)
 304      (or name "*selector*"))))
 305
 306   (set (make-local-variable 'selector/entries) entries)
 307   (set (make-local-variable 'selector/callback) callback)
 308   (set (make-local-variable 'selector/pattern) "")
 309   (set (make-local-variable 'selector/highlight-overlay) (make-overlay 0 0))
 310   (set (make-local-variable 'selector/current-entry) nil)
 311   (set (make-local-variable 'selector/nb-total-entries)
 312        (number-to-string (length entries)))
 313   (set (make-local-variable 'selector/nb-shown-entries) "?")
 314
 315   (overlay-put selector/highlight-overlay 'face 'selector/selection)
 316
 317   (add-hook 'post-command-hook 'selector/move-highlight-overlay nil t)
 318   (selector/mode)
 319   (selector/refresh)
 320   )
 321
 322 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 323 ;; To open recent files
 324 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 325
 326 (defun selector/filename-to-string (filename)
 327   "Generate the line associated to a filename for `selector/quick-pick-recent'"
 328   (concat
 329    " "
 330    (if (file-remote-p s)
 331        "          "
 332      (propertize
 333       (format-time-string   "%a %b %e" (elt (file-attributes s) 5))
 334       'face 'selector/date))
 335
 336    " -- "
 337
 338    (if (string-match abbreviated-home-dir s)
 339        (concat (propertize
 340                 (substring s 0 (match-end 0)) 'face 'selector/dim)
 341                (substring s (match-end 0)))
 342      s)
 343    )
 344   )
 345
 346 (defun selector/find-file (filename)
 347   "Callback function for `selector/quick-pick-recent'. When
 348 called with a universal argument, allows the user to edit the
 349 filename."
 350   (interactive)
 351   (if current-prefix-arg
 352       (find-file (read-file-name
 353                   "Find file: "
 354                   (file-name-directory filename)
 355                   nil
 356                   nil
 357                   (file-name-nondirectory filename)))
 358     (find-file filename)))
 359
 360 (defun selector/quick-pick-recent ()
 361   "Open a file picked in `recentf-list' with the dynamic
 362 pattern-matching search implemented in `selector/select'. With a
 363 prefix argument, allows to edit the filename after selection."
 364   (interactive)
 365
 366   (unless (and (boundp recentf-mode) recentf-mode)
 367     (error "recentf mode must be turned on"))
 368
 369   (selector/select
 370
 371    (mapcar
 372     (lambda (s)
 373       (cons (selector/filename-to-string s) s))
 374     recentf-list)
 375
 376    'selector/find-file
 377    "*selector find-file*"
 378    ))
 379
 380 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 381 ;; To search in the current buffer
 382 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 383
 384 (defun selector/quick-move-in-buffer ()
 385   "Move the cursor in the current buffer to a line selected
 386 dynamically with `selector/select'."
 387   (interactive)
 388   (selector/select
 389    (reverse
 390     (let ((l nil))
 391       (save-excursion
 392         (goto-char (point-min))
 393         (while (< (point) (point-max))
 394           (setq l (cons (cons (buffer-substring (point-at-bol) (point-at-eol))
 395                               (point-at-bol)) l))
 396           (forward-line 1))
 397         l))
 398     )
 399    'goto-char
 400    "*selector buffer move*"
 401    ))
 402
 403 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 404 ;; To switch between buffers
 405 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 406
 407 (defun selector/switch-buffer () (interactive)
 408   "Select the current buffer dynamically with `selector/select'."
 409   (interactive)
 410   (selector/select
 411    (let ((l nil))
 412      (mapc
 413       (lambda (buffer)
 414         (with-current-buffer buffer
 415           (let ((name (buffer-name))
 416                 (size (buffer-size))
 417                 (file (buffer-file-name))
 418                 (modified (buffer-modified-p)))
 419             (when (not (string-match "^ +" name))
 420               (push
 421                (cons
 422                 (replace-regexp-in-string
 423                  " +$"
 424                  ""
 425                  (format
 426                   "% 8d %s %-30s%s"
 427                   size
 428                   (if modified "*" "-")
 429                   name
 430                   (if file (concat
 431                             (replace-regexp-in-string abbreviated-home-dir
 432                                                       "~/" file)
 433                             ) "")
 434                   ))
 435                 buffer)
 436                l)
 437               ))))
 438       (reverse (buffer-list)))
 439      l)
 440    'switch-to-buffer
 441    "*selector switch-buffer*"
 442    ))
 443
 444 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 445 ;; To search among sentences (i.e. between periods, not between \n)
 446 ;; This is work in progress, it currently looks kind of ugly but is
 447 ;; already useful to navigate in a long article
 448 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 449
 450 (defun selector/search-sentence ()
 451   "Move the cursor to a sentence chosen dynamically with
 452 `selector/select'."
 453   (interactive)
 454   (selector/select
 455    (let ((sentences nil))
 456      (save-excursion
 457        (goto-char (point-min))
 458        (while (re-search-forward "[^.]+\\." nil t)
 459          (let ((s (replace-regexp-in-string "^[ \n]+" ""
 460                                             (match-string-no-properties 0)))
 461                (p (match-beginning 0)))
 462            (setq s (replace-regexp-in-string "[ \n]+$" "" s))
 463            (when (> (length s) 1)
 464              (push (cons
 465                     (with-temp-buffer
 466                       (insert s "\n")
 467                       (fill-region (point-min) (point-max))
 468                       (buffer-string))
 469                     p) sentences)))))
 470      (reverse sentences))
 471    'goto-char))
 472
 473 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 474
 475 (defface selector/dir
 476   '((t (:foreground "red")))
 477   "The face for directories.")
 478
 479 (defface selector/symlink
 480   '((t (:foreground "blue")))
 481   "The face for symlinks.")
 482
 483 (defun selector/rec-find-file (&optional filename) (interactive)
 484   (setq filename (or filename
 485                      (and (buffer-file-name) (file-name-directory (buffer-file-name)))
 486                      default-directory))
 487
 488   (if (file-regular-p filename) (find-file filename)
 489     (selector/select
 490      (mapcar
 491       (lambda (file)
 492         (let ((f (car file)))
 493           (cons
 494            (if (file-regular-p f)
 495                f
 496              (if (file-symlink-p f)
 497                  (propertize f 'face 'selector/symlink)
 498                (propertize f 'face 'selector/dir)))
 499            (concat filename "/" f))))
 500       (directory-files-and-attributes filename))
 501      'selector/rec-find-file
 502      (concat "selector " filename)
 503      )))
 504
 505 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;