mirror of https://codeberg.org/cage/tinmop/
168 lines
7.4 KiB
Common Lisp
168 lines
7.4 KiB
Common Lisp
;;;; Copyright (c) 2003, 2004 Nikodemus Siivola, Julian Squires
|
|
;;;;
|
|
;;;; Permission is hereby granted, free of charge, to any person obtaining
|
|
;;;; a copy of this software and associated documentation files (the
|
|
;;;; "Software"), to deal in the Software without restriction, including
|
|
;;;; without limitation the rights to use, copy, modify, merge, publish,
|
|
;;;; distribute, sublicense, and/or sell copies of the Software, and to
|
|
;;;; permit persons to whom the Software is furnished to do so, subject to
|
|
;;;; the following conditions:
|
|
;;;;
|
|
;;;; The above copyright notice and this permission notice shall be included
|
|
;;;; in all copies or substantial portions of the Software.
|
|
;;;;
|
|
;;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
|
|
;;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
|
|
;;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
|
|
;;;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
|
|
;;;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
|
|
;;;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
|
|
;;;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
|
|
|
|
(in-package :complete)
|
|
|
|
(defparameter *complete-function* nil
|
|
"A function that get an hint and return two values:
|
|
- a list of entries that match that hint
|
|
- the common prefix of such candidates.
|
|
See: complete:directory-complete")
|
|
|
|
(defun shortest-candidate (candidates)
|
|
"candidates is a sorted list (by length) -> first of the list,
|
|
otherwise return candidates"
|
|
(and candidates
|
|
(if (listp candidates)
|
|
(first candidates)
|
|
candidates)))
|
|
|
|
(defun reduce-to-common-prefix (items)
|
|
(reduce #'text-utils:common-prefix items))
|
|
|
|
(defun pathname-directory-pathname (pathname)
|
|
"convenience function to make a pathname object to a directory"
|
|
(make-pathname :name nil :type nil
|
|
:defaults pathname))
|
|
|
|
(defun underlying-directory-p (pathname)
|
|
"Find the actual directory of pathname (i.e. resolve file link"
|
|
(case (file-kind pathname)
|
|
(:directory t)
|
|
(:symbolic-link
|
|
(file-kind (merge-pathnames (read-link pathname) pathname)))))
|
|
|
|
;;; We can't easily do zsh-style tab-completion of ~us into ~user, but
|
|
;;; at least we can expand ~ and ~user. The other bug here at the
|
|
;;; moment is that ~nonexistant will complete to the same as ~.
|
|
(defun tilde-expand-string (string)
|
|
"Returns the supplied string, with a prefix of ~ or ~user expanded
|
|
to the appropriate home directory."
|
|
(if (and (> (length string) 0)
|
|
(eql (schar string 0) #\~))
|
|
(flet ((chop (s)
|
|
(subseq s 0 (1- (length s)))))
|
|
(let* ((slash-index (loop for i below (length string)
|
|
when (eql (schar string i) #\/)
|
|
return i))
|
|
(suffix (and slash-index (subseq string slash-index)))
|
|
(uname (subseq string 1 slash-index))
|
|
(homedir (or (cdr (assoc :home (user-info uname)))
|
|
(chop (namestring
|
|
(or (probe-file (user-homedir-pathname))
|
|
(return-from tilde-expand-string
|
|
string)))))))
|
|
(concatenate 'string homedir (or suffix ""))))
|
|
string))
|
|
|
|
(defun directory-complete (string)
|
|
"Return two values completion of 'string' (non nil if can be
|
|
completed) and the common prefix of the completion string."
|
|
(when (text-utils:string-not-empty-p string)
|
|
(let* ((string (tilde-expand-string string))
|
|
(dir (pathname-directory-pathname string))
|
|
(namefun (if (relative-pathname-p string)
|
|
#'namestring
|
|
(lambda (x) (namestring (merge-pathnames x))))))
|
|
(unless (and (underlying-directory-p dir)
|
|
(not (wild-pathname-p dir)))
|
|
(return-from directory-complete (values nil 0)))
|
|
(with-directory-iterator (next dir)
|
|
(when-let* ((all (loop
|
|
for entry = (next)
|
|
while entry collect
|
|
(funcall namefun entry)))
|
|
(candidates (sort (remove-if-not (lambda (a)
|
|
(text-utils:string-starts-with-p string a))
|
|
all)
|
|
(lambda (a b) (< (length a)
|
|
(length b))))))
|
|
(values candidates
|
|
(reduce-to-common-prefix candidates)))))))
|
|
|
|
(defun starts-with-clsr (hint)
|
|
(lambda (a)
|
|
(text-utils:string-starts-with-p hint a)))
|
|
|
|
(defun remove-if-hidden (candidates)
|
|
(remove-if #'db:hidden-recipient-p candidates))
|
|
|
|
(defun folder-complete (hint)
|
|
"Virtual messages folder in db not filesystem directory"
|
|
(when-let ((matching-folders (remove-if-hidden (remove-if-not (starts-with-clsr hint)
|
|
(db:all-folders)))))
|
|
(values matching-folders
|
|
(reduce-to-common-prefix matching-folders))))
|
|
|
|
(defun timeline-complete-fn (folder)
|
|
"Complete a messages timeline prefix"
|
|
(lambda (hint)
|
|
(let* ((all-timelines (if folder
|
|
(db:all-timelines-in-folder folder
|
|
:include-default-timelines t)
|
|
(db:default-timelines)))
|
|
(matching-timelines (remove-if-hidden (remove-if-not (starts-with-clsr hint)
|
|
all-timelines))))
|
|
(values matching-timelines
|
|
(reduce-to-common-prefix matching-timelines)))))
|
|
|
|
(defmacro with-simple-complete (function-name all-choices-list-fn)
|
|
"Generate a complete function using function-name to build the name
|
|
the function and `all-choices-list-fn' as a function that returns a
|
|
list af all possible candidtae for completion."
|
|
(with-gensyms (matched)
|
|
`(defun ,(misc:format-fn-symbol t "~a" function-name) (hint)
|
|
(when-let ((,matched (remove-if-not (starts-with-clsr hint)
|
|
(funcall (function ,all-choices-list-fn)))))
|
|
(values ,matched
|
|
(reduce-to-common-prefix ,matched))))))
|
|
|
|
(with-simple-complete ignored-username-complete db:all-ignored-usernames)
|
|
|
|
(with-simple-complete username-complete db:all-usernames)
|
|
|
|
(with-simple-complete visibility-complete (lambda () swconf:*allowed-status-visibility*))
|
|
|
|
(with-simple-complete unfollowed-user-complete
|
|
(lambda () (db:all-unfollowed-usernames :remove-ignored t)))
|
|
|
|
(with-simple-complete followed-user-complete db:all-followed-usernames)
|
|
|
|
(with-simple-complete tags-complete (lambda ()
|
|
(mapcar #'db:tag->folder-name
|
|
(db:all-subscribed-tags-name))))
|
|
|
|
(with-simple-complete conversation-folder db:all-conversation-folders)
|
|
|
|
(defun make-complete-gemini-iri-fn (prompt)
|
|
(lambda (hint)
|
|
(when-let ((matched (remove-if-not (starts-with-clsr hint)
|
|
(funcall #'db:history-prompt->values prompt))))
|
|
(values matched (reduce-to-common-prefix matched)))))
|
|
|
|
(defun complete-chat-message (hint)
|
|
(append (username-complete hint)
|
|
(directory-complete hint)))
|
|
|
|
(defun complete-always-empty (hint)
|
|
(declare (ignore hint))
|
|
nil)
|