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))
(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))
(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))
(values completed-string t (parse-namestring so-far) (length pathnames) nil))
(values completed-string nil nil (length pathnames) nil))))
;; 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))
(values nil nil nil (length pathnames)
(loop with length = (length directory-prefix)
for name in pathnames
collect (list (subseq (namestring name) length nil)

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

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

0 件のコメント: