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