Climacs の find-file を改善

Climacs の find-file で次の対応。

• /home/user01//tmp を /tmp に
• /tmp/~/foo を /home/user01/foo に
• Tab だけではなく C-i でも補完

C-i は 2 回連続で押さないと補完してくれない。なぜだろう？

そろそろ Emacs を卒業して、Common Lisp の世界で生活したい。

;;; -*- mode: lisp; indent-tabs: nil -*-
;;; (require :info.read-eval-print.climacs.ext)

(in-package :info.read-eval-print.climacs.ext)

(defun test ()
  (format t "Hello World from new project info.read-eval-print.climacs.ext~%"))


(in-package :clim-internals)

(defun ext%normalize-so-far (so-far)
  (reduce (lambda (acc x)
            (ppcre:regex-replace (car x) acc (cadr x)))
          `((".*//"  "/") (".*/~/" ,(namestring (user-homedir-pathname))))
          :initial-value so-far))
(assert (string= (ext%normalize-so-far "/tmp//a") "/a"))
(assert (string= (ext%normalize-so-far "/tmp/~/a") (q:str (namestring (user-homedir-pathname)) "a")))


(defun filename-completer (so-far mode)
  (let* ((so-far (ext%normalize-so-far so-far))
         (directory-prefix
          (if (eq :absolute (car (pathname-directory (pathname so-far))))
              ""
              (namestring #+sbcl *default-pathname-defaults*
                          #+cmu (ext:default-directory)
                          #-(or sbcl cmu) *default-pathname-defaults*)))
         (full-so-far (concatenate 'string directory-prefix so-far))
         (pathnames
          (loop with length = (length full-so-far)
                and wildcard = (format nil "~A*.*"
                                       (loop for start = 0 ; Replace * -> \*
                                             for occurence = (position #\* so-far :start start)
                                             until (= start (length so-far))
                                             until (null occurence)
                                             do (replace so-far "\\*" :start1 occurence)
                                                (setf start (+ occurence 2))
                                             finally (return so-far)))
                for path in
                #+(or sbcl cmu lispworks) (directory wildcard)
                #+openmcl (directory wildcard :directories t)
                #+allegro (directory wildcard :directories-are-files nil)
                #+cormanlisp (nconc (directory wildcard)
                                    (cl::directory-subdirs dirname))
                #-(or sbcl cmu lispworks openmcl allegro cormanlisp)
                (directory wildcard)
                when (let ((mismatch (mismatch (namestring path) full-so-far)))
                       (q:p path full-so-far mismatch)
                       (or (null mismatch) (= mismatch length)))
                  collect path))
         (strings (mapcar #'namestring pathnames))
         (first-string (car strings))
         (length-common-prefix nil)
         (completed-string nil)
         (full-completed-string nil)
         (input-is-directory-p (when (plusp (length so-far))
                                 (char= (aref so-far (1- (length so-far))) #\/))))
    (unless (null pathnames)
      (setf length-common-prefix
            (loop with length = (length first-string)
                  for string in (cdr strings)
                  do (setf length (min length (or (mismatch string first-string) length)))
                  finally (return length))))
    (unless (null pathnames)
      (setf completed-string
            (subseq first-string (length directory-prefix)
                    (if (null (cdr pathnames)) nil length-common-prefix)))
      (setf full-completed-string
            (concatenate 'string directory-prefix completed-string)))
    (case mode
      ((:complete-limited :complete-maximal)
       (cond ((null pathnames)
              (values so-far nil nil 0 nil))
             ((null (cdr pathnames))
              (values completed-string (plusp (length so-far)) (car pathnames) 1 nil))
             (input-is-directory-p
              (values completed-string t (parse-namestring so-far) (length pathnames) nil))
             (t
              (values completed-string nil nil (length pathnames) nil))))
      (:complete
       ;; This is reached when input is activated, if we did
       ;; completion, that would mean that an input of "foo" would
       ;; be expanded to "foobar" if "foobar" exists, even if the
       ;; user actually *wants* the "foo" pathname (to create the
       ;; file, for example).
       (values so-far t so-far 1 nil))
      (:possibilities
       (values nil nil nil (length pathnames)
               (loop with length = (length directory-prefix)
                     for name in pathnames
                     collect (list (subseq (namestring name) length nil)
                                   name)))))))


(in-package :info.read-eval-print.climacs.ext)

;; C-i でも補完
(progn
  (clim:define-gesture-name :complete :keyboard (:tab))
  (clim:define-gesture-name :complete :keyboard (#\i :control) :unique nil))