sepia-ido.el

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