code.delx.au - gnu-emacs/blob - lisp/rfn-eshadow.el

   1 ;;; rfn-eshadow.el --- Highlight `shadowed' part of read-file-name input text
   2 ;;
   3 ;; Copyright (C) 2000-2011 Free Software Foundation, Inc.
   4 ;;
   5 ;; Author: Miles Bader <miles@gnu.org>
   6 ;; Keywords: convenience minibuffer
   7 ;; Package: emacs
   8
   9 ;; This file is part of GNU Emacs.
  10
  11 ;; GNU Emacs is free software: you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation, either version 3 of the License, or
  14 ;; (at your option) any later version.
  15
  16 ;; GNU Emacs is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  23
  24 ;;; Commentary:
  25 ;;
  26 ;; Defines the mode `file-name-shadow-mode'.
  27 ;;
  28 ;; The `read-file-name' function passes its result through
  29 ;; `substitute-in-file-name', so any part of the string preceding
  30 ;; multiple slashes (or a drive indicator on MS-DOS/MS-Windows) is
  31 ;; ignored.
  32 ;;
  33 ;; If `file-name-shadow-mode' is active, any part of the
  34 ;; minibuffer text that would be ignored because of this is given the
  35 ;; properties in `file-name-shadow-properties', which may
  36 ;; be used to make the ignored text invisible, dim, etc.
  37 ;;
  38
  39 ;;; Code:
  40
  41 \f
  42 ;;; Customization
  43
  44 (defconst file-name-shadow-properties-custom-type
  45   '(list
  46     (checklist :inline t
  47                (const :tag "Invisible"
  48                       :doc "Make shadowed part of filename invisible"
  49                       :format "%t%n%h"
  50                       :inline t
  51                       (invisible t intangible t))
  52                (list :inline t
  53                      :format "%v"
  54                      :tag "Face"
  55                      :doc "Display shadowed part of filename using a different face"
  56                      (const :format "" face)
  57                      (face :value file-name-shadow))
  58                (list :inline t
  59                      :format "%t: %v%h"
  60                      :tag "Brackets"
  61                      ;; Note the 4 leading spaces in the doc string;
  62                      ;; this is hack to get around the fact that the
  63                      ;; newline after the second string widget comes
  64                      ;; from the string widget, and doesn't indent
  65                      ;; correctly.  We could use a :size attribute to
  66                      ;; make the second string widget not have a
  67                      ;; terminating newline, but this makes it impossible
  68                      ;; to enter trailing whitespace, and it's desirable
  69                      ;; that it be possible.
  70                      :doc "    Surround shadowed part of filename with brackets"
  71                      (const :format "" before-string)
  72                      (string :format "%v" :size 4 :value "{")
  73                      (const :format "" after-string)
  74                      ;; see above about why the 2nd string doesn't use :size
  75                      (string :format " and: %v" :value "} "))
  76                (list :inline t
  77                      :format "%t: %v%n%h"
  78                      :tag "String"
  79                      :doc "Display a string instead of the shadowed part of filename"
  80                      (const :format "" display)
  81                      (string :format "%v" :size 15 :value "<...ignored...>"))
  82                (const :tag "Avoid"
  83                       :doc "Try to keep cursor out of shadowed part of filename"
  84                       :format "%t%n%h"
  85                       :inline t
  86                       (field shadow)))
  87     (repeat :inline t
  88             :tag "Other Properties"
  89             (list :inline t
  90                   :format "%v"
  91                   (symbol :tag "Property")
  92                   (sexp :tag "Value")))))
  93
  94 (defcustom file-name-shadow-properties
  95   ;; FIXME: should we purecopy this?
  96 '(face file-name-shadow field shadow)
  97   "Properties given to the `shadowed' part of a filename in the minibuffer.
  98 Only used when `file-name-shadow-mode' is active.
  99 If Emacs is not running under a window system,
 100 `file-name-shadow-tty-properties' is used instead."
 101   :type file-name-shadow-properties-custom-type
 102   :group 'minibuffer
 103   :version "22.1")
 104
 105 (defcustom file-name-shadow-tty-properties
 106   (purecopy '(before-string "{" after-string "} " field shadow))
 107   "Properties given to the `shadowed' part of a filename in the minibuffer.
 108 Only used when `file-name-shadow-mode' is active and Emacs
 109 is not running under a window-system; if Emacs is running under a window
 110 system, `file-name-shadow-properties' is used instead."
 111   :type file-name-shadow-properties-custom-type
 112   :group 'minibuffer
 113   :version "22.1")
 114
 115 (defface file-name-shadow
 116   '((t :inherit shadow))
 117   "Face used by `file-name-shadow-mode' for the shadow."
 118   :group 'minibuffer
 119   :version "22.1")
 120
 121 (defvar rfn-eshadow-setup-minibuffer-hook nil
 122   "Minibuffer setup functions from other packages.")
 123
 124 (defvar rfn-eshadow-update-overlay-hook nil
 125   "Customer overlay functions from other packages")
 126
 127 \f
 128 ;;; Internal variables
 129
 130 ;; A list of minibuffers to which we've added a post-command-hook.
 131 (defvar rfn-eshadow-frobbed-minibufs nil)
 132
 133 ;; An overlay covering the shadowed part of the filename (local to the
 134 ;; minibuffer).
 135 (defvar rfn-eshadow-overlay)
 136 (make-variable-buffer-local 'rfn-eshadow-overlay)
 137
 138 \f
 139 ;;; Hook functions
 140
 141 ;; This function goes on minibuffer-setup-hook
 142 (defun rfn-eshadow-setup-minibuffer ()
 143   "Set up a minibuffer for `file-name-shadow-mode'.
 144 The prompt and initial input should already have been inserted."
 145   (when minibuffer-completing-file-name
 146     (setq rfn-eshadow-overlay
 147           (make-overlay (minibuffer-prompt-end) (minibuffer-prompt-end)))
 148     ;; Give rfn-eshadow-overlay the user's props.
 149     (let ((props
 150            (if window-system
 151                file-name-shadow-properties
 152              file-name-shadow-tty-properties)))
 153       (while props
 154         (overlay-put rfn-eshadow-overlay (pop props) (pop props))))
 155     ;; Turn on overlay evaporation so that we don't have to worry about
 156     ;; odd effects when the overlay sits empty at the beginning of the
 157     ;; minibuffer.
 158     (overlay-put rfn-eshadow-overlay 'evaporate t)
 159     ;; Add our post-command hook, and make sure can remove it later.
 160     (add-to-list 'rfn-eshadow-frobbed-minibufs (current-buffer))
 161     (add-hook 'post-command-hook #'rfn-eshadow-update-overlay nil t)
 162     ;; Run custom hook
 163     (run-hooks 'rfn-eshadow-setup-minibuffer-hook)))
 164
 165 (defsubst rfn-eshadow-sifn-equal (goal pos)
 166   (equal goal (condition-case nil
 167                   (substitute-in-file-name
 168                    (buffer-substring-no-properties pos (point-max)))
 169                 ;; `substitute-in-file-name' can fail on partial input.
 170                 (error nil))))
 171
 172 ;; post-command-hook to update overlay
 173 (defun rfn-eshadow-update-overlay ()
 174   "Update `rfn-eshadow-overlay' to cover shadowed part of minibuffer input.
 175 This is intended to be used as a minibuffer `post-command-hook' for
 176 `file-name-shadow-mode'; the minibuffer should have already
 177 been set up by `rfn-eshadow-setup-minibuffer'."
 178   (condition-case nil
 179       (let ((goal (substitute-in-file-name (minibuffer-contents)))
 180             (mid (overlay-end rfn-eshadow-overlay))
 181             (start (minibuffer-prompt-end))
 182             (end (point-max)))
 183         (unless
 184             ;; Catch the common case where the shadow does not need to move.
 185             (and mid
 186                  (or (eq mid end)
 187                      (not (rfn-eshadow-sifn-equal goal (1+ mid))))
 188                  (or (eq mid start)
 189                      (rfn-eshadow-sifn-equal goal mid)))
 190           ;; Binary search for the greatest position still equivalent to
 191           ;; the whole.
 192           (while (or (< (1+ start) end)
 193                      (if (and (< (1+ end) (point-max))
 194                               (rfn-eshadow-sifn-equal goal (1+ end)))
 195                          ;; (SIFN end) != goal, but (SIFN (1+end)) == goal,
 196                          ;; We've reached a discontinuity: this can happen
 197                          ;; e.g. if `end' point to "/:...".
 198                          (setq start (1+ end) end (point-max))))
 199             (setq mid (/ (+ start end) 2))
 200             (if (rfn-eshadow-sifn-equal goal mid)
 201                 (setq start mid)
 202               (setq end mid)))
 203           (move-overlay rfn-eshadow-overlay (minibuffer-prompt-end) start))
 204         ;; Run custom hook
 205         (run-hooks 'rfn-eshadow-update-overlay-hook))
 206     ;; `substitute-in-file-name' can fail on partial input.
 207     (error nil)))
 208 \f
 209 (define-minor-mode file-name-shadow-mode
 210   "Toggle File-Name Shadow mode.
 211 When active, any part of a filename being read in the minibuffer
 212 that would be ignored (because the result is passed through
 213 `substitute-in-file-name') is given the properties in
 214 `file-name-shadow-properties', which can be used to make
 215 that portion dim, invisible, or otherwise less visually noticeable.
 216
 217 With prefix argument ARG, turn on if positive, otherwise off.
 218 Returns non-nil if the new state is enabled."
 219   :global t
 220   ;; We'd like to use custom-initialize-set here so the setup is done
 221   ;; before dumping, but at the point where the defcustom is evaluated,
 222   ;; the corresponding function isn't defined yet, so
 223   ;; custom-initialize-set signals an error.
 224   :initialize 'custom-initialize-delay
 225   :init-value t
 226   :group 'minibuffer
 227   :version "22.1"
 228   (if file-name-shadow-mode
 229       ;; Enable the mode
 230       (add-hook 'minibuffer-setup-hook 'rfn-eshadow-setup-minibuffer)
 231     ;; Disable the mode
 232     (remove-hook 'minibuffer-setup-hook 'rfn-eshadow-setup-minibuffer)
 233     ;; Remove our entry from any post-command-hook variable's it's still in
 234     (dolist (minibuf rfn-eshadow-frobbed-minibufs)
 235       (with-current-buffer minibuf
 236         (remove-hook 'post-command-hook #'rfn-eshadow-update-overlay t)))
 237     (setq rfn-eshadow-frobbed-minibufs nil)))
 238
 239
 240 (provide 'rfn-eshadow)
 241
 242 ;;; rfn-eshadow.el ends here