sepia-ido.el

   1 (eval-when-compile
   2   (require 'ido)
   3   (require 'cl))
   4
   5 (defun* sepia-icompleting-recursive-read (prompt dir &key
   6                                                  list-fn
   7                                                  parent-fn
   8                                                  chdir-fn
   9                                                  rootp-fn
  10                                                  slashp-fn)
  11 "Like `ido-read-file-name', but without all the file-specific
  12 bells-and-whistles.  Arguments are:
  13     list-fn           list current dir
  14     parent-fn         get parent dir
  15     chdir-fn          change to dir
  16     rootp-fn          is dir root?
  17     slashp-fn         does dir end in slash?
  18 "
  19   (flet ((ido-make-file-list (prefix)
  20            (setq ido-temp-list (funcall list-fn (or prefix ""))))
  21          (ido-exhibit () (sepia-ido-exhibit))
  22          (ido-is-root-directory (&optional dir)
  23            (funcall rootp-fn (or dir ido-current-directory)))
  24          (ido-set-current-directory (dir &optional subdir foo)
  25            (funcall chdir-fn dir subdir foo))
  26          (ido-final-slash (str &rest blah)
  27            (funcall slashp-fn str))
  28          (ido-file-name-directory (x)
  29            (funcall parent-fn x))
  30          ;; And stub out these two suckers...
  31          (ido-is-tramp-root (&rest blah) nil)
  32          (ido-nonreadable-directory-p (dir) nil))
  33     (setq ido-current-directory dir)
  34     (let ((ido-saved-vc-hb nil)
  35           (ido-directory-nonreadable nil)
  36           (ido-context-switch-command 'ignore)
  37           (ido-directory-too-big nil))
  38       (sepia-ido-read-internal 'file prompt nil nil t))))
  39
  40 (defun sepia-rootp-fn (dir)
  41   (member dir '("" "::")))
  42
  43 (defun sepia-chdir-fn (dir sub blah)
  44   (setq dir
  45         (cond
  46           (sub (concat dir (car ido-matches)))
  47           ((member dir (list ido-current-directory "::")) dir)
  48           ((string-match (concat "^" dir) ido-current-directory)
  49            dir)
  50           (t (concat ido-current-directory (car ido-matches)))))
  51   ;; XXX what's that doing?!?
  52   ;; (unless ido-matches
  53   ;;   (error "help! dir = %s" dir))
  54   ;; (setq dir (concat ido-current-directory (car ido-matches)))
  55   (if (string-equal ido-current-directory dir)
  56       nil
  57       ;; XXX: concat?
  58       (setq ido-current-directory (ido-final-slash dir))
  59       (when (get-buffer ido-completion-buffer)
  60         (kill-buffer ido-completion-buffer))
  61       t))
  62
  63 (defun sepia-list-fn (str)
  64   (let ((listing-dir ido-current-directory))
  65     (when (or (not ido-current-directory)
  66               (string-match "^\\(?:::\\)?$" ido-current-directory))
  67       (setq ido-current-directory ""
  68             listing-dir "::"))
  69     (mapcar (lambda (x)
  70               (substring x (length listing-dir)))
  71             (xref-apropos (concat listing-dir str ".*") t "CODE" "STASH"))))
  72
  73 (defun sepia-dir-fn (str)
  74   (if (string-match "^\\(.*::\\)[^:]+:*$" str)
  75       (match-string 1 str)
  76       ""))
  77
  78 (defun sepia-slashp-fn (str)
  79   (cond
  80     ((string-match "::$" str) str)
  81     ((string-match ":$" str) (concat str ":"))
  82     (t nil)))
  83
  84 (defun sepia-jump-to-symbol ()
  85 "Jump to a symbol's definition using ido-like completion."
  86   (interactive)
  87   (let ((pack (concat (sepia-buffer-package) "::"))
  88         ido-case-fold)
  89     (sepia-location
  90      (sepia-icompleting-recursive-read "Jump to: " pack
  91                                        :list-fn 'sepia-list-fn
  92                                        :parent-fn 'sepia-dir-fn
  93                                        :chdir-fn 'sepia-chdir-fn
  94                                        :rootp-fn 'sepia-rootp-fn
  95                                        :slashp-fn 'sepia-slashp-fn)
  96      t)))
  97
  98 (defun sepia-ido-exhibit ()
  99   "Post command hook for `sepia-icompleting-recursive-read'.
 100 Like `ido-exhibit', but without weird file-specific bells and
 101 whistles.  Since ido is controlled through a bunch of dynamic
 102 variables, it's hard to figure out what can be safely cut."
 103
 104   (when (= ido-use-mycompletion-depth (minibuffer-depth))
 105     (let ((contents (buffer-substring-no-properties (minibuffer-prompt-end)
 106                                                     (point-max)))
 107           (buffer-undo-list t)
 108           try-single-dir-match)
 109
 110       (save-excursion
 111         (goto-char (point-max))
 112         ;; Register the end of input, so we know where the extra stuff
 113         ;; (match-status info) begins:
 114         (unless (boundp 'ido-eoinput)
 115           ;; In case it got wiped out by major mode business:
 116           (make-local-variable 'ido-eoinput))
 117         (setq ido-eoinput (point))
 118
 119         ;; Handle explicit directory changes
 120         (when (ido-final-slash contents)
 121           (ido-set-current-directory contents)
 122           (setq ido-exit 'refresh)
 123           (exit-minibuffer)
 124           (setq ido-text-init ""))
 125
 126         ;; Update the list of matches
 127         (setq ido-text contents)
 128         (ido-set-matches)
 129
 130         ;; Enter something ending in a "slash"
 131         (when (and ido-matches
 132                    (null (cdr ido-matches))
 133                    (ido-final-slash (car ido-matches))
 134                    try-single-dir-match)
 135           (ido-set-current-directory
 136            (concat ido-current-directory (car ido-matches)))
 137           (setq ido-exit 'refresh)
 138           (exit-minibuffer))
 139
 140         (setq ido-rescan t)
 141
 142         (ido-set-common-completion)
 143         (let ((inf (ido-completions
 144                     contents
 145                     minibuffer-completion-table
 146                     minibuffer-completion-predicate
 147                     (not minibuffer-completion-confirm))))
 148           (insert inf))))))
 149
 150
 151 (defun sepia-ido-complete ()
 152   "Try to complete the current pattern amongst the file names."
 153   (interactive)
 154   (let (res)
 155     (cond
 156
 157       ((not ido-matches)
 158        (when ido-completion-buffer
 159          (call-interactively (setq this-command ido-cannot-complete-command))))
 160
 161       ((= 1 (length ido-matches))
 162        ;; only one choice, so select it.
 163        (if (not ido-confirm-unique-completion)
 164            (exit-minibuffer)
 165            (setq ido-rescan (not ido-enable-prefix))
 166            (delete-region (minibuffer-prompt-end) (point))
 167            (insert (car ido-matches))))
 168
 169       (t ;; else there could be some completions
 170        (setq res ido-common-match-string)
 171        (if (and (not (memq res '(t nil)))
 172                 (not (equal res ido-text)))
 173            ;; found something to complete, so put it in the minibuffer.
 174            (progn
 175              ;; move exact match to front if not in prefix mode
 176              (setq ido-rescan (not ido-enable-prefix))
 177              (delete-region (minibuffer-prompt-end) (point))
 178              (insert res))
 179            ;; else nothing to complete
 180            (call-interactively
 181             (setq this-command ido-cannot-complete-command)))))))
 182
 183 (defun sepia-ido-read-internal (item prompt history &optional
 184                                 default require-match initial)
 185   "Perform the ido-read-buffer and ido-read-file-name functions.
 186 Return the name of a buffer or file selected.
 187 PROMPT is the prompt to give to the user.
 188 DEFAULT if given is the default directory to start with.
 189 If REQUIRE-MATCH is non-nil, an existing file must be selected.
 190 If INITIAL is non-nil, it specifies the initial input string."
 191   (let
 192       ((ido-cur-item item)
 193        (ido-entry-buffer (current-buffer))
 194        (ido-process-ignore-lists t)
 195        (ido-process-ignore-lists-inhibit nil)
 196        (ido-set-default-item t)
 197        ido-default-item
 198        ido-selected
 199        ido-final-text
 200        (done nil)
 201        (icomplete-mode nil) ;; prevent icomplete starting up
 202        ;; Exported dynamic variables:
 203        ido-cur-list
 204        ido-ignored-list
 205        (ido-rotate-temp nil)
 206        (ido-keep-item-list nil)
 207        (ido-use-merged-list nil)
 208        (ido-try-merged-list t)
 209        (ido-pre-merge-state nil)
 210        (ido-case-fold ido-case-fold)
 211        (ido-enable-prefix ido-enable-prefix)
 212        (ido-enable-regexp ido-enable-regexp)
 213        )
 214
 215     ;; (ido-define-mode-map)
 216     (ido-setup-completion-map)
 217     (setq ido-text-init initial)
 218     (while (not done)
 219       (ido-trace "\n_LOOP_" ido-text-init)
 220       (setq ido-exit nil)
 221       (setq ido-rescan t)
 222       (setq ido-rotate nil)
 223       (setq ido-text "")
 224       ;; XXX: set ido-default-item?
 225
 226       (if ido-keep-item-list
 227         (setq ido-keep-item-list nil
 228               ido-rescan nil)
 229         (setq ido-ignored-list nil
 230               ido-cur-list (ido-make-file-list ido-default-item)))
 231
 232       (setq ido-rotate-temp nil)
 233
 234       (ido-set-matches)
 235       (if (and ido-matches (eq ido-try-merged-list 'auto))
 236           (setq ido-try-merged-list t))
 237       (let
 238           ((minibuffer-local-completion-map ido-completion-map)
 239            (max-mini-window-height (or ido-max-window-height
 240                                        (and (boundp 'max-mini-window-height)
 241                                             max-mini-window-height)))
 242            (ido-completing-read t)
 243            (ido-require-match require-match)
 244            (ido-use-mycompletion-depth (1+ (minibuffer-depth)))
 245            (show-paren-mode nil))
 246         ;; prompt the user for the file name
 247         (setq ido-exit nil)
 248         (setq ido-final-text
 249               (catch 'ido
 250                 (completing-read
 251                  (ido-make-prompt item prompt)
 252                  '(("dummy" . 1)) nil nil ; table predicate require-match
 253                  (prog1 ido-text-init (setq ido-text-init nil)) ;initial-contents
 254                  history))))
 255
 256       (if (get-buffer ido-completion-buffer)
 257           (kill-buffer ido-completion-buffer))
 258
 259       (cond
 260        ((eq ido-exit 'refresh)
 261         (if (and (eq ido-use-merged-list 'auto)
 262                  (or (input-pending-p)))
 263             (setq ido-use-merged-list nil
 264                   ido-keep-item-list t))
 265         nil)
 266
 267        ((eq ido-exit 'done)
 268         (setq done t
 269               ido-selected ido-text
 270               ido-exit nil)
 271
 272         (setq ido-text-init (read-string (concat prompt "[EDIT] ")
 273                                          ido-final-text)))
 274
 275        ((eq ido-exit 'keep)
 276         (setq ido-keep-item-list t))
 277
 278        ((memq ido-exit '(dired fallback findfile findbuffer))
 279         (setq done t))
 280
 281        ((eq ido-exit 'updir)
 282         ;; cannot go up if already at the root-dir (Unix) or at the
 283         ;; root-dir of a certain drive (Windows or MS-DOS).
 284         (unless (ido-is-root-directory)
 285           (ido-set-current-directory (ido-file-name-directory
 286                                       (substring ido-current-directory 0 -2)))
 287           (setq ido-set-default-item t)))
 288
 289        ;; Handling the require-match must be done in a better way.
 290        ((and require-match (not (ido-existing-item-p)))
 291         (error "must specify valid item"))
 292
 293        (t
 294         (setq ido-selected
 295               (if (or (eq ido-exit 'takeprompt)
 296                       (null ido-matches))
 297                   ido-final-text
 298                 ;; else take head of list
 299                 (ido-name (car ido-matches))))
 300
 301         (cond
 302
 303          ((ido-final-slash ido-selected)
 304           (ido-set-current-directory ido-current-directory ido-selected)
 305           (setq ido-set-default-item t))
 306
 307          (t
 308           (setq done t))))))
 309     ido-selected))
 310
 311 (provide 'sepia-ido)