auto-install/icicles-mac.el

   1 ;;; icicles-mac.el --- Macros for Icicles
   2 ;;
   3 ;; Filename: icicles-mac.el
   4 ;; Description: Macros for Icicles
   5 ;; Author: Drew Adams
   6 ;; Maintainer: Drew Adams
   7 ;; Copyright (C) 1996-2011, Drew Adams, all rights reserved.
   8 ;; Created: Mon Feb 27 09:24:28 2006
   9 ;; Version: 22.0
  10 ;; Last-Updated: Thu Sep  8 13:35:20 2011 (-0700)
  11 ;;           By: dradams
  12 ;;     Update #: 813
  13 ;; URL: http://www.emacswiki.org/cgi-bin/wiki/icicles-mac.el
  14 ;; Keywords: internal, extensions, help, abbrev, local, minibuffer,
  15 ;;           keys, apropos, completion, matching, regexp, command
  16 ;; Compatibility: GNU Emacs: 20.x, 21.x, 22.x, 23.x
  17 ;;
  18 ;; Features that might be required by this library:
  19 ;;
  20 ;;   None
  21 ;;
  22 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  23 ;;
  24 ;;; Commentary:
  25 ;;
  26 ;;  This is a helper library for library `icicles.el'.  It defines
  27 ;;  macros.  For Icicles documentation, see `icicles-doc1.el' and
  28 ;;  `icicles-doc2.el'.
  29 ;;
  30 ;;  User options defined here (in Custom group `Icicles'):
  31 ;;
  32 ;;    `icicle-byte-compile-eval-after-load-flag'.
  33 ;;
  34 ;;  Macros defined here:
  35 ;;
  36 ;;    `icicle-buffer-bindings', `icicle-condition-case-no-debug',
  37 ;;    `icicle-define-add-to-alist-command', `icicle-define-command',
  38 ;;    `icicle-define-file-command', `icicle-define-sort-command',
  39 ;;    `icicle-file-bindings', `icicle-maybe-byte-compile-after-load',
  40 ;;    `icicle-with-selected-window'.
  41 ;;
  42 ;;  Functions defined here:
  43 ;;
  44 ;;    `icicle-assoc-delete-all', `icicle-try-switch-buffer'.
  45 ;;
  46 ;;  Standard Emacs function defined here for older Emacs versions:
  47 ;;
  48 ;;    `select-frame-set-input-focus'.
  49 ;;
  50 ;;  You might also be interested in my library `imenu+.el', which
  51 ;;  teaches the macros defined here to Imenu, so the functions defined
  52 ;;  with those macros show up in Imenu menus.
  53 ;;
  54 ;;  I've also included some commented-out code at the end, which you
  55 ;;  might want to use in your init file (~/.emacs).  It provides
  56 ;;  better indentation for the doc string when you use the macros here
  57 ;;  in your code.
  58 ;;
  59 ;;  For descriptions of changes to this file, see `icicles-chg.el'.
  60 ;;
  61 ;;  ******************
  62 ;;  NOTE: Whenever you update Icicles (i.e., download new versions of
  63 ;;  Icicles source files), I recommend that you do the following:
  64 ;;
  65 ;;      1. Delete all existing byte-compiled Icicles files
  66 ;;         (icicles*.elc).
  67 ;;      2. Load Icicles (`load-library' or `require').
  68 ;;      3. Byte-compile the source files.
  69 ;;
  70 ;;  In particular, always load `icicles-mac.el' (not
  71 ;;  `icicles-mac.elc') before you byte-compile new versions of the
  72 ;;  files, in case there have been any changes to Lisp macros (in
  73 ;;  `icicles-mac.el').
  74 ;;  ******************
  75
  76 ;;(@> "Index")
  77 ;;
  78 ;;  If you have library `linkd.el' and Emacs 22 or later, load
  79 ;;  `linkd.el' and turn on `linkd-mode' now.  It lets you easily
  80 ;;  navigate around the sections of this doc.  Linkd mode will
  81 ;;  highlight this Index, as well as the cross-references and section
  82 ;;  headings throughout this file.  You can get `linkd.el' here:
  83 ;;  http://dto.freeshell.org/notebook/Linkd.html.
  84 ;;
  85 ;;  (@> "User Options")
  86 ;;  (@> "Macros")
  87 ;;  (@> "Functions")
  88
  89 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  90 ;;
  91 ;; This program is free software; you can redistribute it and/or modify
  92 ;; it under the terms of the GNU General Public License as published by
  93 ;; the Free Software Foundation; either version 3, or (at your option)
  94 ;; any later version.
  95 ;;
  96 ;; This program is distributed in the hope that it will be useful,
  97 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  98 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  99 ;; GNU General Public License for more details.
 100 ;;
 101 ;; You should have received a copy of the GNU General Public License
 102 ;; along with this program; see the file COPYING.  If not, write to the
 103 ;; Free Software Foundation, Inc., 51 Franklin Street,
 104 ;; Fifth Floor, Boston, MA 02110-1301, USA.
 105 ;;
 106 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 107 ;;
 108 ;;; Code:
 109
 110 ;; Byte-compiling this file, you will likely get some error or warning
 111 ;; messages. All of the following are benign.  They are due to
 112 ;; differences between different versions of Emacs.
 113 ;;
 114 ;; Compiling in Emacs 20:
 115 ;;
 116 ;; the function x-focus-frame is not known to be defined.
 117
 118 (eval-when-compile (when (< emacs-major-version 21) (require 'cl))) ;; for Emacs < 21: dolist, push
 119
 120 ;; Quiet the byte compiler for Emacs versions before 22.  For some reason, a value is required.
 121 (unless (boundp 'minibuffer-completing-symbol)
 122   (defvar minibuffer-completing-symbol nil)
 123   (defvar minibuffer-message-timeout 2)
 124   (defvar minibuffer-prompt-properties nil))
 125
 126 ;; Quiet the byte-compiler.
 127 (defvar icicle-inhibit-try-switch-buffer)
 128 (defvar read-file-name-completion-ignore-case)
 129
 130 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 131
 132 ;;(@* "User Options")
 133
 134 ;;; User Options -----------------------------------------------------
 135
 136 ;;;###autoload
 137 (defcustom icicle-byte-compile-eval-after-load-flag t
 138   "*Non-nil means byte-compile definitions made within `eval-after-load'.
 139 Some Icicles functions (commands, in particular) work only if a given
 140 library is loaded.  Some such functions are defined inside an
 141 `eval-after-load' form, which means they are defined only, and as soon
 142 as, the required library is loaded.
 143
 144 If this option is non-nil then those function definitions are
 145 byte-compiled.  This compilation adds a bit to the load time, in
 146 effect, but it means that the functions run faster."
 147   :type 'boolean :group 'Icicles-Miscellaneous)
 148
 149 ;;(@* "Macros")
 150
 151 ;;; Macros -----------------------------------------------------------
 152
 153 ;; $$$$$$
 154 ;; Same as vanilla `condition-case-no-debug', which is available starting with Emacs 23.
 155 ;; (defmacro icicle-condition-case-no-debug (var bodyform &rest handlers)
 156 ;;   "Like `condition-case', but does not catch anything when debugging.
 157 ;; Specifically, non-nil `debug-on-error' means catch no signals.
 158 ;; This is the same as `condition-case-no-debug': added to use in older
 159 ;; Emacs versions too."
 160 ;;   (let ((bodysym  (make-symbol "body")))
 161 ;;     `(let ((,bodysym  (lambda () ,bodyform)))
 162 ;;       (if debug-on-error
 163 ;;           (funcall ,bodysym)
 164 ;;         (condition-case ,var
 165 ;;             (funcall ,bodysym)
 166 ;;           ,@handlers)))))
 167
 168 (defmacro icicle-condition-case-no-debug (var bodyform &rest handlers)
 169   "Like `condition-case', but do not catch per `debug-on-(error|quit)'.
 170 If both `debug-on-error' and `debug-on-quit' are non-nil, then handle
 171 only other signals - enter the debugger for errors and `C-g'.
 172
 173 If `debug-on-error' is non-nil and `debug-on-quit' is nil, then handle
 174 all signals except errors that would be caught by an `error' handler.
 175 Enter the debugger on such errors.
 176
 177 If `debug-on-quit' is non-nil and `debug-on-error' is nil, then handle
 178 all signals except quitting.  Enter the debugger on quit (`C-g').
 179
 180 NOTE:
 181 1. This does not treat `error' and `quit' handlers specially when
 182    they are in a list that is the car of a handler.  In such a case
 183    the handler remains in effect in spite of the values of
 184    `debug-on-(error|quit)'.
 185
 186 2. Only errors that would be caught by an `error' handler (if one were
 187    present) enter the debugger when `debug-on-error' is non-nil.  When
 188    a specific error handler (e.g. `arith-error') is present, it still
 189    handles such an error - the debugger is not entered just because
 190    `debug-on-error' is non-nil."
 191   (let ((bodysym  (make-symbol "body")))
 192     `(let ((,bodysym  (lambda () ,bodyform)))
 193       (cond ((and debug-on-error debug-on-quit)
 194              (condition-case ,var
 195                  (funcall ,bodysym)
 196                ,@(icicle-remove-if
 197                   (lambda (hh) (memq (car hh) '(error quit)))
 198                   handlers)))
 199             (debug-on-error
 200              (condition-case ,var
 201                  (funcall ,bodysym)
 202                ,@(icicle-remove-if
 203                   (lambda (hh) (eq (car hh) 'error))
 204                   handlers)))
 205             (debug-on-quit
 206              (condition-case ,var
 207                  (funcall ,bodysym)
 208                ,@(icicle-remove-if
 209                   (lambda (hh) (eq (car hh) 'quit))
 210                   handlers)))
 211             (t
 212              (condition-case ,var
 213                  (funcall ,bodysym)
 214                ,@handlers))))))
 215
 216 (defmacro icicle-maybe-byte-compile-after-load (function)
 217   "Byte-compile FUNCTION if `icicle-byte-compile-eval-after-load-flag'.
 218 Do nothing if FUNCTION has not been defined (`fboundp')."
 219   `(when (and icicle-byte-compile-eval-after-load-flag (fboundp ',function))
 220     (require 'bytecomp)
 221     (let ((byte-compile-warnings  ())
 222           (byte-compile-verbose   nil))
 223       (byte-compile ',function))))
 224
 225 (if (fboundp 'with-selected-window)     ; Emacs 22+
 226     (defalias 'icicle-with-selected-window (symbol-function 'with-selected-window))
 227   (defmacro icicle-with-selected-window (window &rest body)
 228     "Execute the forms in BODY with WINDOW as the selected window.
 229 The value returned is the value of the last form in BODY.
 230
 231 This macro saves and restores the selected window, as well as the
 232 selected window of each frame.  It does not change the order of
 233 recently selected windows.  If the previously selected window of
 234 some frame is no longer live at the end of BODY, that frame's
 235 selected window is left alone.  If the selected window is no
 236 longer live, then whatever window is selected at the end of BODY
 237 remains selected.
 238
 239 This macro uses `save-current-buffer' to save and restore the
 240 current buffer, since otherwise its normal operation could
 241 potentially make a different buffer current.  It does not alter
 242 the buffer list ordering."
 243     ;; Most of this code is a copy of save-selected-window.
 244     `(let ((save-selected-window-window  (selected-window))
 245            ;; It is necessary to save all of these, because calling
 246            ;; select-window changes frame-selected-window for whatever
 247            ;; frame that window is in.
 248            (save-selected-window-alist   (mapcar #'(lambda (frame)
 249                                                      (list frame (frame-selected-window frame)))
 250                                           (frame-list))))
 251       (save-current-buffer
 252         (unwind-protect
 253              (progn (if (> emacs-major-version 21)
 254                         (select-window ,window 'norecord) ; Emacs 22+
 255                       (select-window ,window))
 256                     ,@body)
 257           (dolist (elt save-selected-window-alist)
 258             (and (frame-live-p (car elt))
 259                  (window-live-p (cadr elt))
 260                  (if (> emacs-major-version 22)
 261                      (set-frame-selected-window (car elt) (cadr elt) 'norecord) ; Emacs 23+
 262                    (set-frame-selected-window (car elt) (cadr elt)))))
 263           (when (window-live-p save-selected-window-window)
 264             (if (> emacs-major-version 21)
 265                 (select-window save-selected-window-window 'norecord) ; Emacs 22+
 266               (select-window save-selected-window-window))))))))
 267
 268 ;;;###autoload
 269 (defmacro icicle-define-add-to-alist-command (command doc-string construct-item-fn alist-var
 270                                               &optional dont-save)
 271   "Define COMMAND that adds an item to an alist user option.
 272 Any items with the same key are first removed from the alist.
 273 DOC-STRING is the doc string of COMMAND.
 274 CONSTRUCT-ITEM-FN is a function that constructs the new item.
 275   It reads user input.
 276 ALIST-VAR is the alist user option.
 277 Optional arg DONT-SAVE non-nil means do not call
 278 `customize-save-variable' to save the updated variable."
 279   `(defun ,command ()
 280     ,(concat doc-string "\n\nNote: Any items with the same key are first removed from the alist.")
 281     (interactive)
 282     (let ((new-item  (funcall ,construct-item-fn)))
 283       (setq ,alist-var  (icicle-assoc-delete-all (car new-item) ,alist-var))
 284       (push new-item ,alist-var)
 285       ,(unless dont-save `(customize-save-variable ',alist-var ,alist-var))
 286       (message "Added to `%s': `%S'" ',alist-var new-item))))
 287
 288 (defmacro icicle-buffer-bindings (&optional pre-bindings post-bindings)
 289   "Bindings to use in multi-command definitions for buffer names.
 290 PRE-BINDINGS is a list of additional bindings, which are created
 291 before the others.  POST-BINDINGS is similar, but the bindings are
 292 created after the others."
 293   ;; We use `append' rather than backquote syntax (with ,@post-bindings in particular) because of a bug
 294   ;; in Emacs 20.  This ensures that you can byte-compile in, say, Emacs 20 and still use the result
 295   ;; in later Emacs releases.
 296   `,(append
 297      pre-bindings
 298      `((completion-ignore-case                      (or (and (boundp 'read-buffer-completion-ignore-case)
 299                                                          read-buffer-completion-ignore-case)
 300                                                      completion-ignore-case))
 301        (icicle-show-Completions-initially-flag      (or icicle-show-Completions-initially-flag
 302                                                      icicle-buffers-ido-like-flag))
 303        (icicle-top-level-when-sole-completion-flag  (or icicle-top-level-when-sole-completion-flag
 304                                                      icicle-buffers-ido-like-flag))
 305        (icicle-default-value                        (if (and icicle-buffers-ido-like-flag
 306                                                              icicle-default-value)
 307                                                         icicle-buffers-ido-like-flag
 308                                                       icicle-default-value))
 309        (icicle-must-match-regexp                    icicle-buffer-match-regexp)
 310        (icicle-must-not-match-regexp                icicle-buffer-no-match-regexp)
 311        (icicle-must-pass-after-match-predicate      icicle-buffer-predicate)
 312        (icicle-require-match-flag                   icicle-buffer-require-match-flag)
 313        (icicle-extra-candidates                     icicle-buffer-extras)
 314        (icicle-ignore-space-prefix-flag             icicle-buffer-ignore-space-prefix-flag)
 315        (icicle-delete-candidate-object              'icicle-kill-a-buffer) ; `S-delete' kills current buf
 316        (icicle-transform-function                   'icicle-remove-dups-if-extras)
 317        (icicle--temp-orders
 318         (append (list
 319                  '("by last access")    ; Renamed from "turned OFF'.
 320                  '("*...* last" . icicle-buffer-sort-*...*-last)
 321                  '("by buffer size" . icicle-buffer-smaller-p)
 322                  '("by major mode name" . icicle-major-mode-name-less-p)
 323                  (and (fboundp 'icicle-mode-line-name-less-p)
 324                   '("by mode-line mode name" . icicle-mode-line-name-less-p))
 325                  '("by file/process name" . icicle-buffer-file/process-name-less-p))
 326          (delete '("turned OFF") (copy-sequence icicle-sort-orders-alist))))
 327        ;; Put `icicle-buffer-sort' first.  If already in the list, move it, else add it, to beginning.
 328        (icicle-sort-orders-alist
 329         (progn (when (and icicle-buffer-sort-first-time-p icicle-buffer-sort)
 330                  (setq icicle-sort-comparer           icicle-buffer-sort
 331                        icicle-buffer-sort-first-time-p  nil))
 332                (if icicle-buffer-sort
 333                    (let ((already-there  (rassq icicle-buffer-sort icicle--temp-orders)))
 334                      (if already-there
 335                          (cons already-there (setq icicle--temp-orders
 336                                                    (delete already-there icicle--temp-orders)))
 337                        (cons `("by `icicle-buffer-sort'" . ,icicle-buffer-sort) icicle--temp-orders)))
 338                  icicle--temp-orders)))
 339        (icicle-candidate-alt-action-fn
 340         (or icicle-candidate-alt-action-fn (icicle-alt-act-fn-for-type "buffer")))
 341        (icicle-all-candidates-list-alt-action-fn
 342         (or icicle-all-candidates-list-alt-action-fn (icicle-alt-act-fn-for-type "buffer")))
 343        (icicle-bufflist
 344         (if current-prefix-arg
 345             (cond ((zerop (prefix-numeric-value current-prefix-arg))
 346                    (let ((this-mode  major-mode))
 347                      (icicle-remove-if-not #'(lambda (bf)
 348                                                (with-current-buffer bf (eq major-mode this-mode)))
 349                                            (buffer-list))))
 350                   ((< (prefix-numeric-value current-prefix-arg) 0)
 351                    (cdr (assq 'buffer-list (frame-parameters))))
 352                   (t
 353                    (icicle-remove-if-not #'(lambda (bf) (buffer-file-name bf)) (buffer-list))))
 354           (buffer-list))))
 355      post-bindings))
 356
 357 (defmacro icicle-file-bindings (&optional pre-bindings post-bindings)
 358   "Bindings to use in multi-command definitions for file names.
 359 PRE-BINDINGS is a list of additional bindings, which are created
 360 before the others.  POST-BINDINGS is similar, but the bindings are
 361 created after the others."
 362   ;; We use `append' rather than backquote syntax (with ,@post-bindings in particular) because of a bug
 363   ;; in Emacs 20.  This ensures that you can byte-compile in, say, Emacs 20 and still use the result
 364   ;; in later Emacs releases.
 365   `,(append
 366      pre-bindings
 367      `((completion-ignore-case
 368         (or (and (boundp 'read-file-name-completion-ignore-case) read-file-name-completion-ignore-case)
 369          completion-ignore-case))
 370        (icicle-show-Completions-initially-flag      (or icicle-show-Completions-initially-flag
 371                                                      icicle-files-ido-like-flag))
 372        (icicle-top-level-when-sole-completion-flag  (or icicle-top-level-when-sole-completion-flag
 373                                                      icicle-files-ido-like-flag))
 374        (icicle-default-value                        (if (and icicle-files-ido-like-flag
 375                                                              icicle-default-value)
 376                                                         icicle-files-ido-like-flag
 377                                                       ;;  Get default via `M-n', but do not insert it.
 378                                                       (and (memq icicle-default-value '(t nil))
 379                                                            icicle-default-value)))
 380        (icicle-must-match-regexp                    icicle-file-match-regexp)
 381        (icicle-must-not-match-regexp                icicle-file-no-match-regexp)
 382        (icicle-must-pass-after-match-predicate      icicle-file-predicate)
 383        (icicle-require-match-flag                   icicle-file-require-match-flag)
 384        (icicle-extra-candidates                     icicle-file-extras)
 385        (icicle-transform-function                   'icicle-remove-dups-if-extras)
 386        ;; Put `icicle-file-sort' first.  If already in the list, move it, else add it, to beginning.
 387        (icicle--temp-orders                         (copy-sequence icicle-sort-orders-alist))
 388        (icicle-sort-orders-alist
 389         (progn (when (and icicle-file-sort-first-time-p icicle-file-sort)
 390                  (setq icicle-sort-comparer           icicle-file-sort
 391                        icicle-file-sort-first-time-p  nil))
 392                (if icicle-file-sort
 393                    (let ((already-there  (rassq icicle-file-sort icicle--temp-orders)))
 394                      (if already-there
 395                          (cons already-there (setq icicle--temp-orders
 396                                                    (delete already-there icicle--temp-orders)))
 397                        (cons `("by `icicle-file-sort'" ,@icicle-file-sort) icicle--temp-orders)))
 398                  icicle--temp-orders)))
 399        (icicle-candidate-help-fn                    #'(lambda (cand)
 400                                                         (icicle-describe-file cand current-prefix-arg)))
 401        (icicle-candidate-alt-action-fn
 402         (or icicle-candidate-alt-action-fn (icicle-alt-act-fn-for-type "file")))
 403        (icicle-all-candidates-list-alt-action-fn
 404         (or icicle-all-candidates-list-alt-action-fn (icicle-alt-act-fn-for-type "file")))
 405        (icicle-delete-candidate-object              'icicle-delete-file-or-directory))
 406      post-bindings))
 407
 408 ;;;###autoload
 409 (defmacro icicle-define-command
 410     (command doc-string function prompt collection &optional
 411      predicate require-match initial-input hist def inherit-input-method
 412      bindings first-sexp undo-sexp last-sexp not-interactive-p)
 413   ;; Hard-code these in doc string, because \\[...] prefers ASCII
 414   ;; `C-RET'   instead of `\\[icicle-candidate-action]'
 415   ;; `C-down'  instead of `\\[icicle-next-candidate-per-mode-action]'
 416   ;; `C-up', `C-wheel-up' instead of `\\[icicle-previous-candidate-per-mode-action]'
 417   ;; `C-next'  instead of `\\[icicle-next-apropos-candidate-action]'
 418   ;; `C-prior' instead of `\\[icicle-previous-apropos-candidate-action]'
 419   ;; `C-end'   instead of `\\[icicle-next-prefix-candidate-action]'
 420   ;; `C-home'  instead of `\\[icicle-previous-prefix-candidate-action]'
 421   "Define COMMAND with DOC-STRING based on FUNCTION.
 422 COMMAND is a symbol.  DOC-STRING is a string.
 423 FUNCTION is a function that takes one argument, read as input.
 424   (If the argument to FUNCTION is a file name or directory name, then
 425   use macro `icicle-define-file-command', instead.)
 426
 427 BINDINGS is a list of `let*' bindings added around the command code.
 428   The following bindings are pre-included - you can refer to them in
 429   the command body (including in FIRST-SEXP, LAST-SEXP, UNDO-SEXP).
 430
 431   `icicle-orig-buff'   is bound to (current-buffer)
 432   `icicle-orig-window' is bound to (selected-window)
 433 BINDINGS is macroexpanded, so it can also be a macro call that expands
 434 to a list of bindings.  For example, you can use
 435 `icicle-buffer-bindings' here.
 436
 437 In case of user quit (`C-g') or error, an attempt is made to restore
 438 the original buffer.
 439
 440 FIRST-SEXP is a sexp evaluated before the main body of the command.
 441 UNDO-SEXP is a sexp evaluated in case of error or if the user quits.
 442 LAST-SEXP is a sexp evaluated after the main body of the command.
 443  It is always evaluated, in particular, even in case of error or quit.
 444 NOT-INTERACTIVE-P non-nil means to define COMMAND as a non-interactive
 445  function that reads multi-command input.
 446
 447 Other arguments are as for `completing-read'.
 448
 449 In order, the created command does this:
 450
 451  - Uses DOC-STRING, with information about Icicles bindings appended.
 452  - Binds BINDINGS for the rest of the command.
 453  - Evaluates FIRST-SEXP.
 454  - Reads input with `completing-read', using PROMPT, COLLECTION,
 455    PREDICATE, REQUIRE-MATCH, INITIAL-INPUT, HIST, DEF, and
 456    INHERIT-INPUT-METHOD.
 457  - Calls FUNCTION on the input that was read.
 458  - Evaluates UNDO-SEXP in case of error or if the user quits.
 459  - Evaluates LAST-SEXP.
 460
 461 The created command also binds `icicle-candidate-action-fn' to a
 462 function that calls FUNCTION on the current completion candidate.
 463 Note that the BINDINGS are of course not in effect within
 464 `icicle-candidate-action-fn'."
 465   `(defun ,command ()
 466     ,(concat doc-string "\n\nRead input, then "
 467              (and (symbolp function) (concat "call `" (symbol-name function) "'\nto "))
 468              "act on it.
 469
 470 Input-candidate completion and cycling are available.  While cycling,
 471 these keys with prefix `C-' are active:
 472
 473 \\<minibuffer-local-completion-map>\
 474 `C-mouse-2', `C-RET' - Act on current completion candidate only
 475 `C-down', `C-wheel-down' - Move to next completion candidate and act
 476 `C-up', `C-wheel-up' - Move to previous completion candidate and act
 477 `C-next'  - Move to next apropos-completion candidate and act
 478 `C-prior' - Move to previous apropos-completion candidate and act
 479 `C-end'   - Move to next prefix-completion candidate and act
 480 `C-home'  - Move to previous prefix-completion candidate and act
 481 `\\[icicle-all-candidates-action]'     - Act on *all* candidates, successively (careful!)
 482
 483 When candidate action and cycling are combined (e.g. `C-next'), user
 484 option `icicle-act-before-cycle-flag' determines which occurs first.
 485
 486 With prefix `C-M-' instead of `C-', the same keys (`C-M-mouse-2',
 487 `C-M-RET', `C-M-down', and so on) provide help about candidates.
 488
 489 Use `mouse-2', `RET', or `S-RET' to finally choose a candidate, or
 490 `C-g' to quit.
 491
 492 This is an Icicles command - see command `icicle-mode'.")
 493     ,(and (not not-interactive-p) '(interactive))
 494     (let* ((icicle-orig-buff    (current-buffer))
 495            (icicle-orig-window  (selected-window))
 496            ,@(macroexpand bindings)
 497            (icicle-candidate-action-fn
 498             (lambda (candidate)
 499               (let ((minibuffer-completion-table      minibuffer-completion-table)
 500                     (minibuffer-completion-predicate  minibuffer-completion-predicate)
 501                     (minibuffer-completion-confirm    minibuffer-completion-confirm)
 502                     (minibuffer-completing-file-name  minibuffer-completing-file-name)
 503                     (minibuffer-completing-symbol     (and (boundp 'minibuffer-completing-symbol)
 504                                                            minibuffer-completing-symbol))
 505                     (minibuffer-exit-hook             minibuffer-exit-hook)
 506                     (minibuffer-help-form             minibuffer-help-form)
 507                     (minibuffer-history-variable      minibuffer-history-variable)
 508                     (minibuffer-history-case-insensitive-variables
 509                      minibuffer-history-case-insensitive-variables)
 510                     (minibuffer-history-sexp-flag     minibuffer-history-sexp-flag)
 511                     (minibuffer-message-timeout       (and (boundp 'minibuffer-message-timeout)
 512                                                            minibuffer-message-timeout))
 513                     (minibuffer-prompt-properties     (and (boundp 'minibuffer-prompt-properties)
 514                                                            minibuffer-prompt-properties))
 515                     (minibuffer-setup-hook            minibuffer-setup-hook)
 516                     (minibuffer-text-before-history   minibuffer-text-before-history))
 517                 (icicle-condition-case-no-debug in-action-fn
 518                     ;; Treat 3 cases, because previous use of `icicle-candidate-action-fn'
 519                     ;; might have killed the buffer or deleted the window.
 520                     (cond ((and (buffer-live-p icicle-orig-buff) (window-live-p icicle-orig-window))
 521                            (with-current-buffer icicle-orig-buff
 522                              (save-selected-window (select-window icicle-orig-window)
 523                                                    (funcall #',function candidate))))
 524                           ((window-live-p icicle-orig-window)
 525                            (save-selected-window (select-window icicle-orig-window)
 526                                                  (funcall #',function candidate)))
 527                           (t
 528                            (funcall #',function candidate)))
 529                   (error (unless (string= "Cannot switch buffers in minibuffer window"
 530                                           (error-message-string in-action-fn))
 531                            (error "%s" (error-message-string in-action-fn)))
 532                          (when (window-live-p icicle-orig-window)
 533                            (select-window icicle-orig-window)
 534                            (select-frame-set-input-focus (selected-frame)))
 535                          (funcall #',function candidate)))
 536                 (select-window (minibuffer-window))
 537                 (select-frame-set-input-focus (selected-frame))
 538                 nil))))                 ; Return nil for success.
 539       ,first-sexp
 540       (icicle-condition-case-no-debug act-on-choice
 541           (let ((cmd-choice  (completing-read ,prompt ,collection ,predicate ,require-match
 542                                               ,initial-input ,hist ,def ,inherit-input-method)))
 543             ;; Reset after reading input, so that commands can tell whether input has been read.
 544             (setq icicle-candidate-action-fn  nil)
 545             (funcall #',function cmd-choice))
 546         (quit  (icicle-try-switch-buffer icicle-orig-buff) ,undo-sexp)
 547         (error (icicle-try-switch-buffer icicle-orig-buff) ,undo-sexp
 548                (error "%s" (error-message-string act-on-choice))))
 549       ,last-sexp)))
 550
 551 ;;;###autoload
 552 (defmacro icicle-define-file-command
 553     (command doc-string function prompt &optional
 554      dir default-filename require-match initial-input predicate
 555      bindings first-sexp undo-sexp last-sexp not-interactive-p)
 556   ;; Hard-code these in doc string, because \\[...] prefers ASCII
 557   ;; `C-RET'   instead of `\\[icicle-candidate-action]'
 558   ;; `C-down'  instead of `\\[icicle-next-candidate-per-mode-action]'
 559   ;; `C-up', `C-wheel-up' instead of `\\[icicle-previous-candidate-per-mode-action]'
 560   ;; `C-next'  instead of `\\[icicle-next-apropos-candidate-action]'
 561   ;; `C-prior' instead of `\\[icicle-previous-apropos-candidate-action]'
 562   ;; `C-end'   instead of `\\[icicle-next-prefix-candidate-action]'
 563   ;; `C-home'  instead of `\\[icicle-previous-prefix-candidate-action]'
 564   "Define COMMAND with DOC-STRING based on FUNCTION.
 565 COMMAND is a symbol.  DOC-STRING is a string.
 566 FUNCTION is a function that takes one file-name or directory-name
 567 argument, read as input.  (Use macro `icicle-define-command' for a
 568 FUNCTION whose argument is not a file or directory name.)
 569
 570 BINDINGS is a list of `let*' bindings added around the command code.
 571   The following bindings are pre-included - you can refer to them in
 572   the command body (including in FIRST-SEXP, LAST-SEXP, UNDO-SEXP).
 573
 574   `icicle-orig-buff'   is bound to (current-buffer)
 575   `icicle-orig-window' is bound to (selected-window)
 576 BINDINGS is macroexpanded, so it can also be a macro call that expands
 577 to a list of bindings.  For example, you can use
 578 `icicle-buffer-bindings' or `icicle-file-bindings' here.
 579
 580 In case of user quit (`C-g') or error, an attempt is made to restore
 581 the original buffer.
 582
 583 FIRST-SEXP is a sexp evaluated before the main body of the command.
 584 UNDO-SEXP is a sexp evaluated in case of error or if the user quits.
 585 LAST-SEXP is a sexp evaluated after the main body of the command.
 586  It is always evaluated, in particular, even in case of error or quit.
 587 NOT-INTERACTIVE-P non-nil means to define COMMAND as a non-interactive
 588  function that reads multi-command input.
 589
 590 Other arguments are as for `read-file-name'.
 591
 592 In order, the created command does this:
 593
 594  - Uses DOC-STRING, with information about Icicles bindings appended.
 595  - Binds BINDINGS for the rest of the command.
 596  - Evaluates FIRST-SEXP.
 597  - Reads input with `read-file-name', using PROMPT, DIR,
 598    DEFAULT-FILENAME, REQUIRE-MATCH, INITIAL-INPUT, and PREDICATE.
 599  - Calls FUNCTION on the input that was read.
 600  - Evaluates UNDO-SEXP in case of error or if the user quits.
 601  - Evaluates LAST-SEXP.
 602
 603 The created command also binds `icicle-candidate-action-fn' to a
 604 function that calls FUNCTION on the current completion candidate.
 605 Note that the BINDINGS are of course not in effect within
 606 `icicle-candidate-action-fn'."
 607   `(defun ,command ()
 608     ,(concat doc-string "\n\nRead input, then "
 609              (and (symbolp function) (concat "call `" (symbol-name function) "'\nto "))
 610              "act on it.
 611
 612 Input-candidate completion and cycling are available.  While cycling,
 613 these keys with prefix `C-' are active:
 614
 615 \\<minibuffer-local-completion-map>\
 616 `C-mouse-2', `C-RET' - Act on current completion candidate only
 617 `C-down', `C-wheel-down' - Move to next completion candidate and act
 618 `C-up', `C-wheel-up' - Move to previous completion candidate and act
 619 `C-next'  - Move to next apropos-completion candidate and act
 620 `C-prior' - Move to previous apropos-completion candidate and act
 621 `C-end'   - Move to next prefix-completion candidate and act
 622 `C-home'  - Move to previous prefix-completion candidate and act
 623 `\\[icicle-all-candidates-action]'     - Act on *all* candidates, successively (careful!)
 624
 625 When candidate action and cycling are combined (e.g. `C-next'), user
 626 option `icicle-act-before-cycle-flag' determines which occurs first.
 627
 628 With prefix `C-M-' instead of `C-', the same keys (`C-M-mouse-2',
 629 `C-M-RET', `C-M-down', and so on) provide help about candidates.
 630
 631 Use `mouse-2', `RET', or `S-RET' to finally choose a candidate, or
 632 `C-g' to quit.
 633
 634 This is an Icicles command - see command `icicle-mode'.")
 635     ,(and (not not-interactive-p) '(interactive))
 636     (let* ((icicle-orig-buff    (current-buffer))
 637            (icicle-orig-window  (selected-window))
 638            ,@(macroexpand bindings)
 639            (icicle-candidate-action-fn
 640             (lambda (candidate)
 641               (let ((minibuffer-completion-table      minibuffer-completion-table)
 642                     (minibuffer-completion-predicate  minibuffer-completion-predicate)
 643                     (minibuffer-completion-confirm    minibuffer-completion-confirm)
 644                     (minibuffer-completing-file-name  minibuffer-completing-file-name)
 645                     (minibuffer-completing-symbol     (and (boundp 'minibuffer-completing-symbol)
 646                                                            minibuffer-completing-symbol))
 647                     (minibuffer-exit-hook             minibuffer-exit-hook)
 648                     (minibuffer-help-form             minibuffer-help-form)
 649                     (minibuffer-history-variable      minibuffer-history-variable)
 650                     (minibuffer-history-case-insensitive-variables
 651                      minibuffer-history-case-insensitive-variables)
 652                     (minibuffer-history-sexp-flag     minibuffer-history-sexp-flag)
 653                     (minibuffer-message-timeout       (and (boundp 'minibuffer-message-timeout)
 654                                                            minibuffer-message-timeout))
 655                     (minibuffer-prompt-properties     (and (boundp 'minibuffer-prompt-properties)
 656                                                            minibuffer-prompt-properties))
 657                     (minibuffer-setup-hook            minibuffer-setup-hook)
 658                     (minibuffer-text-before-history   minibuffer-text-before-history))
 659                 (setq candidate  (expand-file-name
 660                                   candidate (icicle-file-name-directory icicle-last-input)))
 661                 (icicle-condition-case-no-debug in-action-fn
 662                     ;; Treat 3 cases, because previous use of `icicle-candidate-action-fn'
 663                     ;; might have deleted the file or the window.
 664                     (cond ((and (buffer-live-p icicle-orig-buff) (window-live-p icicle-orig-window))
 665                            (with-current-buffer icicle-orig-buff
 666                              (save-selected-window (select-window icicle-orig-window)
 667                                                    (funcall #',function candidate))))
 668                           ((window-live-p icicle-orig-window)
 669                            (save-selected-window (select-window icicle-orig-window)
 670                                                  (funcall #',function candidate)))
 671                           (t
 672                            (funcall #',function candidate)))
 673                   (error (unless (string= "Cannot switch buffers in minibuffer window"
 674                                           (error-message-string in-action-fn))
 675                            (error "%s" (error-message-string in-action-fn)))
 676                          (when (window-live-p icicle-orig-window)
 677                            (select-window icicle-orig-window)
 678                            (select-frame-set-input-focus (selected-frame)))
 679                          (funcall #',function candidate)))
 680                 (select-window (minibuffer-window))
 681                 (select-frame-set-input-focus (selected-frame))
 682                 nil))))                 ; Return nil for success.
 683       ,first-sexp
 684       (icicle-condition-case-no-debug act-on-choice
 685           (let ((file-choice
 686                  (if (< emacs-major-version 21) ; No predicate arg for Emacs 20.
 687                      (read-file-name ,prompt ,dir ,default-filename ,require-match ,initial-input)
 688                    (read-file-name ,prompt ,dir ,default-filename ,require-match
 689                                    ,initial-input ,predicate))))
 690             ;; Reset after reading input, so that commands can tell whether input has been read.
 691             (setq icicle-candidate-action-fn  nil) ; Reset after completion.
 692             (funcall #',function file-choice))
 693         (quit  (icicle-try-switch-buffer icicle-orig-buff) ,undo-sexp)
 694         (error (icicle-try-switch-buffer icicle-orig-buff) ,undo-sexp
 695                (error "%s" (error-message-string act-on-choice))))
 696       ,last-sexp)))
 697
 698 ;;;###autoload
 699 (defmacro icicle-define-sort-command (sort-order comparison-fn doc-string)
 700   "Define a command to sort completions by SORT-ORDER.
 701 SORT-ORDER is a short string (or symbol) describing the sort order.
 702  It is used after the phrase \"Sorting is now \".  Examples: \"by date\",
 703  \"alphabetically\", \"directories first\", and \"previously used first\".
 704
 705 The new command is named by replacing any spaces in SORT-ORDER with
 706 hyphens (`-') and then adding the prefix `icicle-sort-'.
 707
 708 COMPARISON-FN is a function that compares two strings, returning
 709  non-nil if and only if the first string sorts before the second.
 710
 711 DOC-STRING is the doc string of the new command."
 712   (unless (stringp sort-order) (setq sort-order  (symbol-name sort-order)))
 713   (let ((command  (intern (concat "icicle-sort-"
 714                                   (replace-regexp-in-string "\\s-+" "-" sort-order)))))
 715     `(progn
 716       (setq icicle-sort-orders-alist  (icicle-assoc-delete-all
 717                                        ,sort-order
 718                                        icicle-sort-orders-alist))
 719       (push (cons ,sort-order ',comparison-fn) icicle-sort-orders-alist)
 720       (defun ,command ()
 721         ,doc-string
 722         (interactive)
 723         (setq icicle-sort-comparer  #',comparison-fn)
 724         (message "Sorting is now %s%s" ,sort-order (if icicle-reverse-sort-p ", REVERSED" ""))
 725         (icicle-complete-again-update)))))
 726
 727 ;;(@* "Functions")
 728
 729 ;;; Functions --------------------------------------------------------
 730
 731 (defun icicle-assoc-delete-all (key alist)
 732   "Delete from ALIST all elements whose car is `equal' to KEY.
 733 Return the modified alist.
 734 Elements of ALIST that are not conses are ignored."
 735   (while (and (consp (car alist)) (equal (car (car alist)) key))
 736     (setq alist  (cdr alist)))
 737   (let ((tail  alist)  tail-cdr)
 738     (while (setq tail-cdr  (cdr tail))
 739       (if (and (consp (car tail-cdr))  (equal (car (car tail-cdr)) key))
 740           (setcdr tail (cdr tail-cdr))
 741         (setq tail  tail-cdr))))
 742   alist)
 743
 744 (defun icicle-try-switch-buffer (buffer)
 745   "Try to switch to BUFFER, first in same window, then in other window."
 746   (when (and (buffer-live-p buffer) (not icicle-inhibit-try-switch-buffer))
 747     (condition-case err-switch-to
 748         (switch-to-buffer buffer)
 749       (error (and (string= "Cannot switch buffers in minibuffer window"
 750                            (error-message-string err-switch-to))
 751                   ;; Try another window.  Don't bother if the buffer to switch to is a minibuffer.
 752                   (condition-case err-switch-other
 753                       (unless (string-match "\\` \\*Minibuf-[0-9]+\\*\\'" (buffer-name buffer))
 754                         (switch-to-buffer-other-window buffer))
 755                     (error (error-message-string err-switch-other)))))))) ; Return error message string.
 756
 757 (unless (fboundp 'select-frame-set-input-focus) ; Defined in Emacs 22.
 758   (defun select-frame-set-input-focus (frame)
 759     "Select FRAME, raise it, and set input focus, if possible."
 760     (select-frame frame)
 761     (raise-frame frame)
 762     ;; Ensure, if possible, that frame gets input focus.
 763     (cond ((eq window-system 'x) (x-focus-frame frame))
 764           ((eq window-system 'w32) (w32-focus-frame frame)))
 765     (cond (focus-follows-mouse (set-mouse-position (selected-frame) (1- (frame-width)) 0)))))
 766
 767
 768 ;;; Miscellaneous  -----------------------------------------
 769
 770 ;; Make Emacs-Lisp mode fontify definitions of Icicles commands.
 771 (font-lock-add-keywords
 772  'emacs-lisp-mode
 773  `((,(concat "(" (regexp-opt '("icicle-define-add-to-alist-command" "icicle-define-command"
 774                                "icicle-define-file-command" "icicle-define-sort-command")
 775                              t)
 776              ;; $$ "\\s-+\\(\\sw\\(\\sw\\|\\s_\\)+\\)")
 777              "\\>[ \t'\(]*\\(\\sw+\\)?")
 778     (1 font-lock-keyword-face)
 779     ;; Index (2 or 3) depends on whether or not shy groups are supported.
 780     ,(list (if (string-match "\\(?:\\)" "") 2 3) 'font-lock-function-name-face nil t))
 781    ("(\\(icicle-condition-case-no-debug\\)\\>" 1 font-lock-keyword-face)))
 782
 783 ;; Make Icicles macros indent better.
 784 (put 'icicle-define-command              'common-lisp-indent-function '(4 &body))
 785 (put 'icicle-define-file-command         'common-lisp-indent-function '(4 &body))
 786 (put 'icicle-define-sort-command         'common-lisp-indent-function '(4 4 &body))
 787 (put 'icicle-define-add-to-alist-command 'common-lisp-indent-function '(4 &body))
 788 (put 'icicle-with-selected-window        'common-lisp-indent-function '(4 &body))
 789 (put 'icicle-condition-case-no-debug     'common-lisp-indent-function '(4 4 &body))
 790
 791 ;; You might also want to use the following or something similar.
 792 ;; (defun lisp-indentation-hack ()
 793 ;;   "Better Lisp indenting.  Use in Lisp mode hooks
 794 ;; such as `lisp-mode-hook', `emacs-lisp-mode-hook', and
 795 ;; `lisp-interaction-mode-hook'."
 796 ;;   (load "cl-indent" nil t)
 797 ;;   (set (make-local-variable 'lisp-indent-function) 'common-lisp-indent-function)
 798 ;;   (setq lisp-indent-maximum-backtracking  10)
 799 ;;   (put 'define-derived-mode 'common-lisp-indent-function '(4 4 4 2 &body))
 800 ;;   (put 'if                  'common-lisp-indent-function '(nil nil &body)))
 801 ;;
 802 ;; (add-hook 'emacs-lisp-mode-hook       'lisp-indentation-hack)
 803 ;; (add-hook 'lisp-mode-hook             'lisp-indentation-hack)
 804 ;; (add-hook 'lisp-interaction-mode-hook 'lisp-indentation-hack)
 805
 806 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 807
 808 (provide 'icicles-mac)
 809
 810 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 811 ;;; icicles-mac.el ends here