diff options
Diffstat (limited to 'lisp/mastodon-toot.el')
| -rw-r--r-- | lisp/mastodon-toot.el | 257 |
1 files changed, 110 insertions, 147 deletions
diff --git a/lisp/mastodon-toot.el b/lisp/mastodon-toot.el index 0e21b0e..1e364df 100644 --- a/lisp/mastodon-toot.el +++ b/lisp/mastodon-toot.el @@ -41,12 +41,6 @@ (require 'cl-lib) (require 'persist) -(when (require 'company nil :noerror) - (declare-function company-mode-on "company") - (declare-function company-begin-backend "company") - (declare-function company-grab-symbol "company") - (defvar company-backends)) - (require 'mastodon-iso) (defvar mastodon-instance-url) @@ -106,18 +100,24 @@ :group 'mastodon-toot :type 'integer) -(defcustom mastodon-toot--enable-completion - (if (require 'company nil :noerror) t nil) +(defcustom mastodon-toot--enable-completion t "Whether to enable completion of mentions and hashtags. +Used for completion in toot compose buffer." + :group 'mastodon-toot + :type 'boolean) + +(defcustom mastodon-toot--use-company-for-completion nil + "Whether to enable company for completion. -Used for completion in toot compose buffer. +When non-nil, `company-mode' is enabled in the toot compose +buffer, and mastodon completion backends are added to +`company-capf'. -This is only used if company mode is installed." +You need to install company yourself to use this." :group 'mastodon-toot :type 'boolean) -(defcustom mastodon-toot--completion-style-for-mentions - (if (require 'company nil :noerror) "following" "off") +(defcustom mastodon-toot--completion-style-for-mentions "all" "The company completion style to use for mentions." :group 'mastodon-toot :type '(choice @@ -205,6 +205,13 @@ send.") "\\(@[^ \n\t]*\\)?\\)" ; with poss domain, * = allow only @ "\\b")) +(defvar mastodon-toot-tag-regex + (concat + ;; preceding space or bol [boundary doesn't work with #] + "\\([\n\t ]\\|^\\)" + "\\(?2:#[1-9a-zA-Z_]+\\)" ; tag + "\\b")) ; boundary + (defvar mastodon-toot-mode-map (let ((map (make-sparse-keymap))) (define-key map (kbd "C-c C-c") #'mastodon-toot--send) @@ -335,7 +342,7 @@ TYPE is a symbol, either 'favourite or 'boost." (list 'favourited-p (not faved)))) (mastodon-toot--action-success (if boost-p - "B" + (mastodon-tl--return-boost-char) (mastodon-tl--return-fave-char)) byline-region remove)) (message (format "%s #%s" (if boost-p msg action) id)))))) @@ -818,129 +825,78 @@ eg. \"feduser@fed.social\" -> \"feduser@fed.social\"." (reverse (append mentions nil)) ""))) -(defun mastodon-toot--mentions-company-meta (candidate) - "Format company completion CANDIDATE's meta field." - (format " %s" - (get-text-property 0 'meta candidate))) - -(defun mastodon-toot--mentions-company-annotation (candidate) - "Format company completion CANDIDATE's annotation." - (format " %s" (get-text-property 0 'annot candidate))) - -(defun mastodon-toot--mentions-company-make-candidate (candidate) - "Construct a company completion CANDIDATE for display." - (let ((display-name (car candidate)) - (handle (cadr candidate)) - (url (caddr candidate))) - (propertize handle 'annot display-name 'meta url))) - -(defun mastodon-toot--tags-company-make-candidate (candidate) - "Construct a company completion CANDIDATE for display." - (let ((tag (concat "#" (car candidate))) - (url (cadr candidate))) - (propertize tag 'annot url 'meta url))) - -(defun mastodon-toot--company-build-candidates (query list-fun make-fun) - "Build a list of completion candidates for a company backend. -QUERY is the search prefix, LIST-FUN builds a list of items to -match against, and MAKE-FUN builds the actual cadidate list item -for display by company." - (let ((query (substring query 1)) ; remove @ or # for search - (res)) - (dolist (item (funcall list-fun query)) - (when (or (string-prefix-p query (substring (cadr item) 1) t) - (string-prefix-p query (car item) t)) - (push (funcall make-fun item) res))) - res)) - -(defun mastodon-toot--mentions-company-candidates (query) - "Given a company QUERY, build a list of candidates. -The query can match both user handles and display names." - (mastodon-toot--company-build-candidates - query - 'mastodon-search--search-accounts-query - 'mastodon-toot--mentions-company-make-candidate)) - -(defun mastodon-toot--tags-company-candidates (query) - "Given a company QUERY, build a list of candidates. -The query is matched against a tag search on the server." - (mastodon-toot--company-build-candidates - query - 'mastodon-search--search-tags-query - 'mastodon-toot--tags-company-make-candidate)) - -(defun mastodon-toot--make-company-backend - (command _backend-name str-prefix candidates-fun annot-fun meta-fun - &optional arg - &rest ignored) - "Make a company backend for `mastodon-toot-mode'. -COMMAND, ARG, IGNORED are all company backend args. -COMMAND is either prefix, to fetch a prefix query, candidates, to -build a list of candidates with query ARG, annotation, to format -an annotation for candidate ARG, or meta, to format meta info for -candidate ARG. IGNORED remains a mystery. - -BACKEND-NAME is the backend's name, STR-PREFIX is used to search -for matches, CANDIDATES-FUN, ANNOT-FUN, and META-FUN are -functions called on ARG to generate formatted candidates, annotation, and -meta fields respectively." - (interactive (list 'interactive)) - (let ((handle-before - ;; hack to handle @handles@with.domains, as "@" is a word/symbol boundary - (if (string= str-prefix "@") - (save-match-data - (save-excursion - (re-search-backward mastodon-toot-handle-regex nil :no-error) - (if (match-string-no-properties 2) - ;; match full handle inc. domain (see the regex for subexp 2) - (buffer-substring-no-properties (match-beginning 2) (match-end 2)) - "")))))) - (cl-case command - (interactive (company-begin-backend (quote backend-name))) - (prefix (when (and (bound-and-true-p mastodon-toot-mode) ; if masto toot minor mode - (save-excursion - (forward-whitespace -1) - (forward-whitespace 1) - (looking-at str-prefix))) - (if (and (string= str-prefix "@") - (> (length handle-before) 1)) ; more than just @ - (concat str-prefix (substring-no-properties handle-before 1)) ;handle - (concat str-prefix (company-grab-symbol))))) ; tag - (candidates (funcall candidates-fun arg)) - (annotation (funcall annot-fun arg)) - (meta (funcall meta-fun arg))))) - -(defun mastodon-toot-mentions (command &optional arg &rest ignored) - "A company completion backend for toot mentions. -COMMAND is either prefix, to fetch a prefix query, candidates, to -build a list of candidates with query ARG, annotation, to format -an annotation for candidate ARG, or meta, to format meta info for -candidate ARG. IGNORED remains a mystery." - (mastodon-toot--make-company-backend - command - 'mastodon-toot-mentions - "@" - 'mastodon-toot--mentions-company-candidates - 'mastodon-toot--mentions-company-annotation - 'mastodon-toot--mentions-company-meta - arg - ignored)) - -(defun mastodon-toot-tags (command &optional arg &rest ignored) - "A company completion backend for toot tags. -COMMAND is either prefix, to fetch a prefix query, candidates, to -build a list of candidates with query ARG, annotation, to format -an annotation for candidate ARG, or meta, to format meta info for -candidate ARG. IGNORED remains a mystery." - (mastodon-toot--make-company-backend - command - 'mastodon-toot-tags - "#" - 'mastodon-toot--tags-company-candidates - 'mastodon-toot--mentions-company-annotation - 'mastodon-toot--mentions-company-meta - arg - ignored)) +(defun mastodon-toot--get-bounds (regex) + "Get bounds of tag or handle before point." + ;; needed because # and @ are not part of any existing thing at point + (save-match-data + (save-excursion + ;; match full handle inc. domain, or tag including # + ;; (see the regexes for subexp 2) + (when (re-search-backward regex nil :no-error) + (cons (match-beginning 2) + (match-end 2)))))) + +(defun mastodon-toot--mentions-capf () + "Build a mentions completion backend for `completion-at-point-functions'." + (let* ((bounds + (mastodon-toot--get-bounds mastodon-toot-handle-regex)) + (start (car bounds)) + (end (cdr bounds))) + (when bounds + (list start + end + ;; only search when necessary: + (completion-table-dynamic + (lambda (_) + ;; TODO: do we really need to set a local var here + ;; just for the annotation-function? + (setq mastodon-toot-completions + (mastodon-search--search-accounts-query + (buffer-substring-no-properties start end) + :capf)))) + :exclusive 'no + :annotation-function + (lambda (candidate) + (concat " " + (mastodon-toot--mentions-annotation-fun candidate))))))) + +(defun mastodon-toot--tags-capf () + "Build a tags completion backend for `completion-at-point-functions'." + (let* ((bounds + (mastodon-toot--get-bounds mastodon-toot-tag-regex)) + (start (car bounds)) + (end (cdr bounds))) + (when bounds + (list start + end + ;; only search when necessary: + (completion-table-dynamic + (lambda (_) + (setq mastodon-toot-completions + (let ((tags (mastodon-search--search-tags-query + (buffer-substring-no-properties start end)))) + (mapcar (lambda (x) + (list (concat "#" (car x)) + (cdr x))) + tags))))) + :exclusive 'no + :annotation-function + (lambda (candidate) + (concat " " + (mastodon-toot--tags-annotation-fun candidate))))))) + +(defvar-local mastodon-toot-completions nil + "The data of completion candidates for the current completion at point.") + +(defun mastodon-toot--mentions-annotation-fun (candidate) + "Given a handle completion CANDIDATE, return its annotation string, a username." + (caddr (assoc candidate mastodon-toot-completions))) + +(defun mastodon-toot--tags-annotation-fun (candidate) + "Given a tag string CANDIDATE, return an annotation, the tag's URL." + ;; FIXME check the list returned here? should be cadr + ;;or make it an alist and use cdr + (caadr (assoc candidate mastodon-toot-completions))) (defun mastodon-toot--reply () "Reply to toot at `point'. @@ -1419,13 +1375,12 @@ Added to `after-change-functions'." ;; stops all text after a handle or mention being propertized: (set-text-properties (cdr header-region) (point-max) nil) ;; TODO: confirm allowed hashtag/handle characters: - (mastodon-toot--propertize-item "\\([\n\t ]\\|^\\)\\(?2:#[1-9a-zA-Z_]+\\)\\b" + (mastodon-toot--propertize-item mastodon-toot-tag-regex 'success (cdr header-region)) - (mastodon-toot--propertize-item - mastodon-toot-handle-regex - 'mastodon-display-name-face - (cdr header-region))))) + (mastodon-toot--propertize-item mastodon-toot-handle-regex + 'mastodon-display-name-face + (cdr header-region))))) (defun mastodon-toot--propertize-item (regex face start) "Propertize item matching REGEX with FACE starting from START." @@ -1473,14 +1428,22 @@ a draft into the buffer." ;; no need to fetch from `mastodon-profile-account-settings' as ;; `mastodon-toot--max-toot-chars' is set when we set it (mastodon-toot--get-max-toot-chars)) - ;; set up company backends: - (when (require 'company nil :noerror) - (when mastodon-toot--enable-completion + ;; set up completion: + (when mastodon-toot--enable-completion + (set ; (setq-local + (make-local-variable 'completion-at-point-functions) + (add-to-list + 'completion-at-point-functions + #'mastodon-toot--mentions-capf)) + (add-to-list + 'completion-at-point-functions + #'mastodon-toot--tags-capf) + ;; company + (when mastodon-toot--use-company-for-completion (set (make-local-variable 'company-backends) - (add-to-list 'company-backends 'mastodon-toot-mentions)) - (add-to-list 'company-backends 'mastodon-toot-tags)) - (unless (bound-and-true-p corfu-mode) ; don't clash w corfu mode + (add-to-list 'company-backends 'company-capf)) (company-mode-on))) + ;; after-change: (make-local-variable 'after-change-functions) (push #'mastodon-toot--update-status-fields after-change-functions) (mastodon-toot--refresh-attachments-display) |