diff options
Diffstat (limited to 'lisp')
| -rw-r--r-- | lisp/mastodon-media.el | 35 | ||||
| -rw-r--r-- | lisp/mastodon-profile.el | 9 | ||||
| -rw-r--r-- | lisp/mastodon-search.el | 21 | ||||
| -rw-r--r-- | lisp/mastodon-tl.el | 113 | ||||
| -rw-r--r-- | lisp/mastodon-toot.el | 257 |
5 files changed, 231 insertions, 204 deletions
diff --git a/lisp/mastodon-media.el b/lisp/mastodon-media.el index 9715a6c..c783130 100644 --- a/lisp/mastodon-media.el +++ b/lisp/mastodon-media.el @@ -35,6 +35,8 @@ ;;; Code: (require 'url-cache) +(autoload 'mastodon-tl--propertize-img-str-or-url "mastodon-tl") + (defvar url-show-status) (defvar mastodon-tl--shr-image-map-replacement) @@ -306,34 +308,23 @@ Replace them with the referenced image." t image-options)) " "))) -(defun mastodon-media--get-media-link-rendering (media-url &optional full-remote-url type caption) +(defun mastodon-media--get-media-link-rendering (media-url &optional full-remote-url + type caption) "Return the string to be written that renders the image at MEDIA-URL. FULL-REMOTE-URL is used for `shr-browse-image'. TYPE is the attachment's type field on the server. CAPTION is the image caption if provided." (let* ((help-echo-base "RET/i: load full image (prefix: copy URL), +/-: zoom, r: rotate, o: save preview") - (help-echo (if caption - (concat help-echo-base - "\n\"" - caption "\"") - help-echo-base))) + (help-echo (if caption + (concat help-echo-base + "\n\"" + caption "\"") + help-echo-base))) (concat - (propertize "[img]" - 'media-url media-url - 'media-state 'needs-loading - 'media-type 'media-link - 'mastodon-media-type type - 'display (create-image mastodon-media--generic-broken-image-data nil t) - 'mouse-face 'highlight - 'mastodon-tab-stop 'image ; for do-link-action-at-point - 'image-url full-remote-url ; for shr-browse-image - 'keymap mastodon-tl--shr-image-map-replacement - 'help-echo (if (or (string= type "image") - (string= type nil) - (string= type "unknown")) ;handle borked images - help-echo - (concat help-echo "\nC-RET: play " type " with mpv"))) - " "))) + (mastodon-tl--propertize-img-str-or-url + "[img]" media-url full-remote-url type help-echo + (create-image mastodon-media--generic-broken-image-data nil t)) + " "))) (provide 'mastodon-media) ;;; mastodon-media.el ends here diff --git a/lisp/mastodon-profile.el b/lisp/mastodon-profile.el index 8cea4d7..d6b2b94 100644 --- a/lisp/mastodon-profile.el +++ b/lisp/mastodon-profile.el @@ -617,15 +617,18 @@ NO-REBLOGS means do not display boosts in statuses." " [locked]") "") "\n ------------\n" - (mastodon-tl--render-text note account) + ;; profile note: ;; account here to enable tab-stops in profile note + (mastodon-tl--render-text note account) + ;; meta fields: (if fields (concat "\n" (mastodon-tl--set-face (mastodon-profile--fields-insert fields) - 'success) - "\n") + 'success)) "") + "\n" + ;; Joined date: (propertize (mastodon-profile--format-joined-date-string joined) 'face 'success) diff --git a/lisp/mastodon-search.el b/lisp/mastodon-search.el index b037faa..65c5aba 100644 --- a/lisp/mastodon-search.el +++ b/lisp/mastodon-search.el @@ -47,7 +47,13 @@ (defvar mastodon-toot--enable-completion-for-mentions) (defvar mastodon-tl--buffer-spec) -;; functions for company completion of mentions in mastodon-toot +;; functions for completion of mentions in mastodon-toot + +(defun mastodon-search--get-user-info-@-capf (account) + "Get user handle, display name and account URL from ACCOUNT." + (list (concat "@" (cdr (assoc 'acct account))) + (cdr (assoc 'url account)) + (cdr (assoc 'display_name account)))) (defun mastodon-search--get-user-info-@ (account) "Get user handle, display name and account URL from ACCOUNT." @@ -55,15 +61,17 @@ (concat "@" (cdr (assoc 'acct account))) (cdr (assoc 'url account)))) -(defun mastodon-search--search-accounts-query (query) +(defun mastodon-search--search-accounts-query (query &optional capf) "Prompt for a search QUERY and return accounts synchronously. Returns a nested list containing user handle, display name, and URL." (interactive "sSearch mastodon for: ") (let* ((url (mastodon-http--api "accounts/search")) (response (if (equal mastodon-toot--completion-style-for-mentions "following") - (mastodon-http--get-json url `(("q" . ,query) ("following" . "true"))) - (mastodon-http--get-json url `(("q" . ,query)))))) - (mapcar #'mastodon-search--get-user-info-@ response))) + (mastodon-http--get-json url `(("q" . ,query) ("following" . "true")) :silent) + (mastodon-http--get-json url `(("q" . ,query)) :silent)))) + (if capf + (mapcar #'mastodon-search--get-user-info-@-capf response) + (mapcar #'mastodon-search--get-user-info-@ response)))) ;; functions for tags completion: @@ -72,10 +80,9 @@ Returns a nested list containing user handle, display name, and URL." QUERY is the string to search." (interactive "sSearch for hashtag: ") (let* ((url (format "%s/api/v2/search" mastodon-instance-url)) - ;; (type-param '(("type" . "hashtags"))) (params `(("q" . ,query) ("type" . "hashtags"))) - (response (mastodon-http--get-json url params)) + (response (mastodon-http--get-json url params :silent)) (tags (alist-get 'hashtags response))) (mapcar #'mastodon-search--get-hashtag-info tags))) diff --git a/lisp/mastodon-tl.el b/lisp/mastodon-tl.el index 46ec8fe..1a726c4 100644 --- a/lisp/mastodon-tl.el +++ b/lisp/mastodon-tl.el @@ -107,6 +107,13 @@ By default fixed width fonts are used." :type '(boolean :tag "Enable using proportional rather than fixed \ width fonts when rendering HTML text")) +(defcustom mastodon-tl--display-caption-not-url-when-no-media t + "Display an image's caption rather than URL. +Only has an effect when `mastodon-tl--display-media-p' is set to +nil." + :group 'mastodon-tl + :type 'boolean) + (defvar-local mastodon-tl--buffer-spec nil "A unique identifier and functions for each Mastodon buffer.") @@ -600,9 +607,6 @@ this just means displaying toot client." (faved (equal 't (mastodon-tl--field 'favourited toot))) (boosted (equal 't (mastodon-tl--field 'reblogged toot))) (bookmarked (equal 't (mastodon-tl--field 'bookmarked toot))) - (bookmark-str (if (fontp (char-displayable-p #10r128278)) - "🔖" - "K")) (visibility (mastodon-tl--field 'visibility toot)) (account (alist-get 'account toot)) (avatar-url (alist-get 'avatar account)) @@ -617,12 +621,14 @@ this just means displaying toot client." ;; displayed for an already boosted/favourited toot or as the result of ;; the toot having just been favourited/boosted. (concat (when boosted - (mastodon-tl--format-faved-or-boosted-byline "B")) + (mastodon-tl--format-faved-or-boosted-byline + (mastodon-tl--return-boost-char))) (when faved (mastodon-tl--format-faved-or-boosted-byline (mastodon-tl--return-fave-char))) (when bookmarked - (mastodon-tl--format-faved-or-boosted-byline bookmark-str))) + (mastodon-tl--format-faved-or-boosted-byline + (mastodon-tl--return-bookmark-char)))) ;; we remove avatars from the byline also, so that they also do not mess ;; with `mastodon-tl--goto-next-toot': (when (and mastodon-tl--show-avatars @@ -667,10 +673,10 @@ this just means displaying toot client." 'face 'mastodon-display-name-face 'follow-link t 'mouse-face 'highlight - 'mastodon-tab-stop 'shr-url - 'shr-url app-url + 'mastodon-tab-stop 'shr-url + 'shr-url app-url 'help-echo app-url - 'keymap mastodon-tl--shr-map-replacement))))) + 'keymap mastodon-tl--shr-map-replacement))))) (if edited-time (concat (if (fontp (char-displayable-p #10r128274)) @@ -685,7 +691,7 @@ this just means displaying toot client." (mastodon-tl--relative-time-description edited-parsed) edited-parsed))) "") - (propertize "\n ------------\n " 'face 'default)) + (propertize "\n ------------\n" 'face 'default)) 'favourited-p faved 'boosted-p boosted 'bookmarked-p bookmarked @@ -694,6 +700,14 @@ this just means displaying toot client." (mastodon-toot--get-toot-edits (alist-get 'id toot))) 'byline t)))) +(defun mastodon-tl--return-boost-char () + "" + (cond + ((fontp (char-displayable-p #10r128257)) + "🔁") + (t + "B"))) + (defun mastodon-tl--return-fave-char () "" (cond @@ -704,6 +718,12 @@ this just means displaying toot client." (t "F"))) +(defun mastodon-tl--return-bookmark-char () + "" + (if (fontp (char-displayable-p #10r128278)) + "🔖" + "K")) + (defun mastodon-tl--format-edit-timestamp (timestamp) "Convert edit TIMESTAMP into a descriptive string." (let ((parsed (ts-human-duration @@ -1018,27 +1038,70 @@ message is a link which unhides/hides the main body." (defun mastodon-tl--media (toot) "Retrieve a media attachment link for TOOT if one exists." - (let* ((media-attachements (mastodon-tl--field 'media_attachments toot)) - (media-string (mapconcat - (lambda (media-attachement) - (let ((preview-url - (alist-get 'preview_url media-attachement)) - (remote-url - (or (alist-get 'remote_url media-attachement) - ;; fallback b/c notifications don't have remote_url - (alist-get 'url media-attachement))) - (type (alist-get 'type media-attachement)) - (caption (alist-get 'description media-attachement))) - (if mastodon-tl--display-media-p - (mastodon-media--get-media-link-rendering - preview-url remote-url type caption) ; 2nd arg for shr-browse-url - (concat "Media::" preview-url "\n")))) - media-attachements ""))) + (let* ((media-attachments (mastodon-tl--field 'media_attachments toot)) + (media-string (mapconcat #'mastodon-tl--media-attachment + media-attachments ""))) (if (not (and mastodon-tl--display-media-p (string-empty-p media-string))) (concat "\n" media-string) ""))) +(defun mastodon-tl--media-attachment (media-attachment) + "Return a propertized string for MEDIA-ATTACHMENT." + (let* ((preview-url + (alist-get 'preview_url media-attachment)) + (remote-url + (or (alist-get 'remote_url media-attachment) + ;; fallback b/c notifications don't have remote_url + (alist-get 'url media-attachment))) + (type (alist-get 'type media-attachment)) + (caption (alist-get 'description media-attachment)) + (display-str + (if (and mastodon-tl--display-caption-not-url-when-no-media + caption) + (concat "Media:: " caption) + (concat "Media:: " preview-url)))) + (if mastodon-tl--display-media-p + ;; return placeholder [img]: + (mastodon-media--get-media-link-rendering + preview-url remote-url type caption) ; 2nd arg for shr-browse-url + ;; return URL/caption: + (concat + (mastodon-tl--propertize-img-str-or-url + (concat "Media:: " preview-url) ;; string + preview-url remote-url type caption + display-str ;; display + ;; FIXME: shr-link underlining is awful for captions with + ;; newlines, as the underlining runs to the edge of the + ;; frame even if the text doesn' + 'shr-link) + "\n")))) + +(defun mastodon-tl--propertize-img-str-or-url (str media-url full-remote-url type + help-echo &optional display face) + "Propertize an media placeholder string \"[img]\" or media URL. + +STR is the string to propertize, MEDIA-URL is the preview link, +FULL-REMOTE-URL is the link to the full resolution image on the +server, TYPE is the media type. +HELP-ECHO, DISPLAY, and FACE are the text properties to add." + (propertize str + 'media-url media-url + 'media-state (when (string= str "[img]") 'needs-loading) + 'media-type 'media-link + 'mastodon-media-type type + 'display display + 'face face + 'mouse-face 'highlight + 'mastodon-tab-stop 'image ; for do-link-action-at-point + 'image-url full-remote-url ; for shr-browse-image + 'keymap mastodon-tl--shr-image-map-replacement + 'help-echo (if (or (string= type "image") + (string= type nil) + (string= type "unknown")) ;handle borked images + help-echo + (concat help-echo "\nC-RET: play " type " with mpv")))) + (defun mastodon-tl--content (toot) "Retrieve text content from TOOT. Runs `mastodon-tl--render-text' and fetches poll or media." diff --git a/lisp/mastodon-toot.el b/lisp/mastodon-toot.el index 0e21b0e..59a3813 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) -Used for completion in toot compose buffer. +(defcustom mastodon-toot--use-company-for-completion nil + "Whether to enable company for completion. -This is only used if company mode is installed." +When non-nil, `company-mode' is enabled in the toot compose +buffer, and mastodon completion backends are added to +`company-capf'. + +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 @@ -188,6 +188,9 @@ Takes its form from `window-configuration-to-register'.") (defvar mastodon-toot--max-toot-chars nil "The maximum allowed characters count for a single toot.") +(defvar-local mastodon-toot-completions nil + "The data of completion candidates for the current completion at point.") + (defvar mastodon-toot-current-toot-text nil "The text of the toot being composed.") @@ -205,6 +208,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 +345,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 +828,75 @@ 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))))))) + +(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) |