mirror of https://codeberg.org/cage/tinmop/
296 lines
13 KiB
Common Lisp
296 lines
13 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"
|
|
(ignore-errors
|
|
(case (fs:file-kind pathname)
|
|
(:directory t)
|
|
(:symbolic-link
|
|
(fs:file-kind (merge-pathnames (fs: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 (elt string 0) #\~))
|
|
(flet ((chop (s)
|
|
(subseq s 0 (1- (length s)))))
|
|
(let* ((slash-index (loop for i below (length string)
|
|
when (eql (elt string i) #\/)
|
|
return i))
|
|
(suffix (and slash-index (subseq string slash-index)))
|
|
(uname (subseq string 1 slash-index))
|
|
(user-info (ignore-errors (os-utils:user-info uname)))
|
|
(homedir (if user-info
|
|
(os-utils:user-info-home user-info)
|
|
(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* ((namestring (fs:relative-file-path->absolute (tilde-expand-string string)))
|
|
(name-dir (if (fs:file-exists-p namestring)
|
|
(fs:parent-dir-path namestring)
|
|
namestring))
|
|
(dir (namestring (pathname->directory-pathname namestring)))
|
|
(absolute-dir-path (fs:relative-file-path->absolute dir)))
|
|
(unless (and (underlying-directory-p dir)
|
|
(not (wild-pathname-p dir)))
|
|
(return-from directory-complete (values nil 0)))
|
|
(let* ((all (fs:collect-children absolute-dir-path))
|
|
(candidates (sort (remove-if-not (lambda (a)
|
|
(text-utils:string-starts-with-p name-dir
|
|
a))
|
|
all)
|
|
#'string<)))
|
|
(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 candidates 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)
|
|
|
|
(let ((memoized (make-hash-table :test #'equalp)))
|
|
|
|
(defun set-username-cache-value (hint)
|
|
(setf (gethash hint memoized)
|
|
(remove-if-not (starts-with-clsr hint)
|
|
(db:all-usernames))))
|
|
|
|
(defun initialize-complete-username-cache ()
|
|
(set-username-cache-value "")
|
|
(loop for i in (coerce "abcdefghijklmnopqrstuvwuxyz" 'list) do
|
|
(set-username-cache-value (string i))))
|
|
|
|
(defun username-complete (hint)
|
|
(multiple-value-bind (matched found)
|
|
(gethash hint memoized)
|
|
(if (null found)
|
|
(progn
|
|
(set-username-cache-value hint)
|
|
(username-complete hint))
|
|
(values matched (reduce-to-common-prefix matched))))))
|
|
|
|
(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 uri-matcher* (scanner bag &optional (accum-strings '()) (accum-indices '()))
|
|
(if (null bag)
|
|
(values accum-strings accum-indices)
|
|
(let ((tested (first bag)))
|
|
(multiple-value-bind (start end)
|
|
(cl-ppcre:scan scanner tested)
|
|
(if start
|
|
(uri-matcher* scanner
|
|
(rest bag)
|
|
(push tested accum-strings)
|
|
(push (loop for i from start below end collect i)
|
|
accum-indices))
|
|
(uri-matcher* scanner (rest bag) accum-strings accum-indices))))))
|
|
|
|
(defun uri-matcher (template bag)
|
|
(let ((strings '())
|
|
(indices '())
|
|
(ordering ()))
|
|
(loop for candidate in bag when (and template
|
|
(<= (length template)
|
|
(length candidate)))
|
|
do
|
|
(when-let ((indices-matched (cl-i18n-utils:fuzzy-match template
|
|
candidate
|
|
:char-comparison-fn #'char-equal
|
|
:similarity-match 5
|
|
:similarity-mismatch -5
|
|
:penalty-weight 1)))
|
|
(push candidate strings)
|
|
(push indices-matched indices)))
|
|
(setf ordering (loop for i from 0 below (length strings) collect i))
|
|
(setf ordering (sort ordering
|
|
(lambda (a b)
|
|
(let* ((indices-a (elt indices a))
|
|
(indices-b (elt indices b))
|
|
(length-a (length indices-a))
|
|
(length-b (length indices-b))
|
|
(nulls-a (count-if #'null indices-a))
|
|
(nulls-b (count-if #'null indices-b))
|
|
(non-nulls-a (- length-a nulls-a))
|
|
(non-nulls-b (- length-b nulls-b)))
|
|
(cond
|
|
((= nulls-a nulls-b)
|
|
(> length-a length-b))
|
|
(t
|
|
(> non-nulls-a non-nulls-b)))))))
|
|
(setf strings (loop for i in ordering collect (elt strings i)))
|
|
(setf indices (loop for i in ordering collect (elt indices i)))
|
|
(values strings indices)))
|
|
|
|
(defun maybe-remove-file-scheme (maybe-file-scheme-iri)
|
|
(let ((parsed-as-iri (iri:iri-parse maybe-file-scheme-iri :null-on-error t)))
|
|
(if (and parsed-as-iri
|
|
(string= (uri:scheme parsed-as-iri) constants:+file-scheme+)
|
|
(and (text-utils:string-starts-with-p (text-utils:strcat constants:+file-scheme+
|
|
"://")
|
|
maybe-file-scheme-iri)))
|
|
(uri:path parsed-as-iri)
|
|
maybe-file-scheme-iri)))
|
|
|
|
(defun expand-iri-as-local-path-p (hint)
|
|
(or (text-utils:string-starts-with-p fs:*directory-sep* hint)
|
|
(text-utils:string-starts-with-p "." hint)
|
|
(text-utils:string-starts-with-p "~" hint)))
|
|
|
|
(defun make-complete-gemini-iri-fn (prompt)
|
|
(lambda (hint)
|
|
(let ((actual-hint (maybe-remove-file-scheme hint)))
|
|
(if (expand-iri-as-local-path-p actual-hint)
|
|
(directory-complete actual-hint)
|
|
(when-let ((bag (remove-duplicates (nconc (db:history-prompt->values prompt)
|
|
(db:bookmark-all-bookmarked-url))
|
|
:test #'string=)))
|
|
(multiple-value-bind (matched-strings indices)
|
|
(uri-matcher actual-hint bag)
|
|
(when matched-strings
|
|
(values matched-strings
|
|
nil ;for fuzzy search common prefix does
|
|
;not makes sense; note also that
|
|
;setting this to nil will force
|
|
;selecting the first item in
|
|
;'complete-window' (see:
|
|
;complete-at-point and
|
|
;insert-selected-suggestion),
|
|
indices))))))))
|
|
|
|
(defun complete-chat-message (hint)
|
|
(append (username-complete hint)
|
|
(directory-complete hint)))
|
|
|
|
(defun complete-always-empty (hint)
|
|
(declare (ignore hint))
|
|
nil)
|
|
|
|
(with-simple-complete bookmark-section-complete
|
|
(lambda () (remove-if #'null (db:bookmark-all-sections))))
|
|
|
|
(with-simple-complete language-codes
|
|
(lambda () constants:+language-codes+))
|
|
|
|
(with-simple-complete fediverse-account
|
|
(lambda () (swconf:all-fediverse-accounts)))
|
|
|
|
(defun quote-hint (a)
|
|
(cl-ppcre:quote-meta-chars a))
|
|
|
|
(defun contains-clsr (hint)
|
|
(handler-case
|
|
(let ((scanner (cl-ppcre:create-scanner (quote-hint hint))))
|
|
(lambda (a)
|
|
(cl-ppcre:scan scanner a)))
|
|
(error ()
|
|
(let ((scanner (cl-ppcre:create-scanner `(:sequence ,hint))))
|
|
(lambda (a)
|
|
(cl-ppcre:scan scanner a))))))
|
|
|
|
(defun bookmark-description-complete-clsr (type)
|
|
(lambda (hint)
|
|
(when-let ((matched (remove-if-not (contains-clsr hint)
|
|
(db:bookmark-description-for-complete type))))
|
|
(values matched (reduce-to-common-prefix matched)))))
|