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