diff options
Diffstat (limited to 'lisp/mastodon-toot.el')
| -rw-r--r-- | lisp/mastodon-toot.el | 233 |
1 files changed, 171 insertions, 62 deletions
diff --git a/lisp/mastodon-toot.el b/lisp/mastodon-toot.el index b2f860f..bffa20e 100644 --- a/lisp/mastodon-toot.el +++ b/lisp/mastodon-toot.el @@ -5,7 +5,6 @@ ;; Author: Johnson Denen <johnson.denen@gmail.com> ;; Marty Hiatt <martianhiatus@riseup.net> ;; Maintainer: Marty Hiatt <martianhiatus@riseup.net> -;; Version: 1.0.0 ;; Homepage: https://codeberg.org/martianh/mastodon.el ;; This file is not part of GNU Emacs. @@ -65,6 +64,7 @@ (autoload 'mastodon-http--put "mastodon-http") (autoload 'mastodon-http--read-file-as-string "mastodon-http") (autoload 'mastodon-http--triage "mastodon-http") +(autoload 'mastodon-kill-window "mastodon") (autoload 'mastodon-profile--fetch-server-account-settings "mastodon-profile") (autoload 'mastodon-profile--fetch-server-account-settings-maybe "mastodon-profile") (autoload 'mastodon-profile--get-source-pref "mastodon-profile") @@ -240,12 +240,20 @@ send.") (group-n 2 ?# (+ (any "A-Z" "a-z" "0-9"))) (| "'" word-boundary))) ; boundary or possessive +(defvar mastodon-toot-emoji-regex + (rx (| (any ?\( "\n" "\t" " ") bol) + (group-n 2 ?: ; opening : + (+ (any "A-Z" "a-z" "0-9" "_")) + (? ?:)) ; closing : + word-boundary)) ; boundary + (defvar mastodon-toot-url-regex ;; adapted from ffap-url-regexp (concat "\\(?2:\\(news\\(post\\)?:\\|mailto:\\|file:\\|\\(ftp\\|https?\\|telnet\\|gopher\\|www\\|wais\\)://\\)" ; uri prefix "[^ \n\t]*\\)" ; any old thing, that is, i.e. we allow invalid/unwise chars ;; "[ .,:;!?]\\b")) + ;; "/" ; poss an ending slash? incompat with boundary end: "\\>")) ; boundary end @@ -509,6 +517,11 @@ base toot." (kill-new url) (message "Toot URL copied to the clipboard."))) +(defun mastodon-toot--open-toot-url () + "Open URL of toot at point." + (interactive) + (browse-url (mastodon-toot--toot-url))) + (defun mastodon-toot--toot-url () "Return the URL of the base toot at point." (let* ((toot (or (mastodon-tl--property 'base-toot) @@ -634,19 +647,36 @@ REPLY-ID, TOOT-VISIBILITY, and TOOT-CW of deleted toot are preseved." ;; TODO set new lang/scheduled props here nil)))) +(defun mastodon-toot--set-toot-media-attachments (media) + "Set the media attachments variables. +MEDIA is the media_attachments data for a status from the server." + (mapcar (lambda (x) + (cl-pushnew (alist-get 'id x) + mastodon-toot--media-attachment-ids) + (cl-pushnew `((:contents . ,(mastodon-http--read-file-as-string + (alist-get 'url x) :url)) + (:description . ,(alist-get 'description x))) + mastodon-toot--media-attachments)) + media)) + (defun mastodon-toot--set-toot-properties - (reply-id visibility cw lang &optional scheduled scheduled-id) + (reply-id visibility cw lang &optional scheduled scheduled-id media) "Set the toot properties for the current redrafted or edited toot. -REPLY-ID, VISIBILITY, CW, SCHEDULED, and LANG are the properties to set." - (when reply-id - (setq mastodon-toot--reply-to-id reply-id)) - (setq mastodon-toot--visibility visibility) - (setq mastodon-toot--scheduled-for scheduled) - (setq mastodon-toot--scheduled-id scheduled-id) - (when (not (string-empty-p lang)) - (setq mastodon-toot--language lang)) - (mastodon-toot--set-cw cw) - (mastodon-toot--update-status-fields)) +REPLY-ID, VISIBILITY, CW, SCHEDULED, and LANG are the properties to set. +MEDIA is the media_attachments data for a status from the server." + (with-current-buffer "*edit toot*" + (when reply-id + (setq mastodon-toot--reply-to-id reply-id)) + (setq mastodon-toot--visibility visibility) + (setq mastodon-toot--scheduled-for scheduled) + (setq mastodon-toot--scheduled-id scheduled-id) + (when (not (string-empty-p lang)) + (setq mastodon-toot--language lang)) + (mastodon-toot--set-cw cw) + (when media + (mastodon-toot--set-toot-media-attachments media)) + (mastodon-toot--refresh-attachments-display) + (mastodon-toot--update-status-fields))) (defun mastodon-toot--kill (&optional cancel) "Kill `mastodon-toot-mode' buffer and window. @@ -658,7 +688,7 @@ CANCEL means the toot was not sent, so we save the toot text as a draft." mastodon-toot-draft-toots-list :test 'equal))) ;; prevent some weird bug when cancelling a non-empty toot: (delete #'mastodon-toot--save-toot-text after-change-functions) - (kill-buffer-and-window) + (quit-window 'kill) (mastodon-toot--restore-previous-window-config prev-window-config))) (defun mastodon-toot--cancel () @@ -826,20 +856,20 @@ instance to edit a toot." ;; Pleroma instances can't handle null-valued ;; scheduled_at args, so only add if non-nil (when scheduled `(("scheduled_at" . ,scheduled))))) - (args-media (when mastodon-toot--media-attachments + (args-media (when mastodon-toot--media-attachment-ids (mastodon-http--build-array-params-alist "media_ids[]" mastodon-toot--media-attachment-ids))) (args-poll (when mastodon-toot-poll (mastodon-toot--build-poll-params))) ;; media || polls: - (args (if mastodon-toot--media-attachments + (args (if mastodon-toot--media-attachment-ids (append args-media args-no-media) (if mastodon-toot-poll (append args-no-media args-poll) args-no-media))) (prev-window-config mastodon-toot-previous-window-config)) - (cond ((and mastodon-toot--media-attachments + (cond ((and mastodon-toot--media-attachment-ids ;; make sure we have media args ;; and the same num of ids as attachments (or (not args-media) @@ -888,14 +918,15 @@ instance to edit a toot." (source-cw (alist-get 'spoiler_text source)) (toot-visibility (alist-get 'visibility toot)) (toot-language (alist-get 'language toot)) - (reply-id (alist-get 'in_reply_to_id toot))) + (reply-id (alist-get 'in_reply_to_id toot)) + (media (alist-get 'media_attachments toot))) (when (y-or-n-p "Edit this toot? ") (mastodon-toot--compose-buffer nil reply-id nil content :edit) (goto-char (point-max)) - ;; adopt reply-to-id, visibility, CW, and language: + ;; adopt reply-to-id, visibility, CW, language, and media: (mastodon-toot--set-toot-properties reply-id toot-visibility - source-cw toot-language) - (mastodon-toot--update-status-fields) + source-cw toot-language nil nil + media) (setq mastodon-toot--edit-item-id id))))))) (defun mastodon-toot--get-toot-source (id) @@ -996,25 +1027,33 @@ Federated user: `username@host.co`." (cons (match-beginning 2) (match-end 2)))))) -(defun mastodon-toot--fetch-completion-candidates (start end &optional tags) +(defun mastodon-toot--fetch-completion-candidates (start end &optional type) "Search for a completion prefix from buffer positions START to END. Return a list of candidates. -If TAGS, we search for tags, else we search for handles." +TYPE is the candidate type, it may be :tags, :handles, or :emoji." ;; we can't save the first two-letter search then only filter the ;; resulting list, as max results returned is 40. (setq mastodon-toot-completions - (if tags - (let ((tags-list (mastodon-search--search-tags-query - (buffer-substring-no-properties start end)))) - (cl-loop for tag in tags-list - collect (cons (concat "#" (car tag)) - (cdr tag)))) - (mastodon-search--search-accounts-query - (buffer-substring-no-properties start end))))) - -(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)) + (cond ((eq type :tags) + (let ((tags-list (mastodon-search--search-tags-query + (buffer-substring-no-properties start end)))) + (cl-loop for tag in tags-list + collect (cons (concat "#" (car tag)) + (cdr tag))))) + ((eq type :emoji) + (cl-loop for e in emojify-user-emojis + collect (car e))) + (t + (mastodon-search--search-accounts-query + (buffer-substring-no-properties start end)))))) + +(defun mastodon-toot--make-capf (regex annot-fun type) + "Build a completion backend for `completion-at-point-functions'. +REGEX is the regex to match preceding text. +TYPE is a keyword symbol for `mastodon-toot--fetch-completion-candidates'. +ANNOT-FUN is a function returning an annotatation from a single +arg, a candidate." + (let* ((bounds (mastodon-toot--get-bounds regex)) (start (car bounds)) (end (cdr bounds))) (when bounds @@ -1025,32 +1064,31 @@ If TAGS, we search for tags, else we search for handles." ;; Interruptible candidate computation, from minad/d mendler, thanks! (let ((result (while-no-input - (mastodon-toot--fetch-completion-candidates start end)))) + (mastodon-toot--fetch-completion-candidates + start end type)))) (and (consp result) result)))) :exclusive 'no :annotation-function (lambda (cand) - (concat " " (mastodon-toot--mentions-annotation-fun cand))))))) + (concat " " (funcall annot-fun cand))))))) + +(defun mastodon-toot--mentions-capf () + "Build a mentions completion backend for `completion-at-point-functions'." + (mastodon-toot--make-capf mastodon-toot-handle-regex + #'mastodon-toot--mentions-annotation-fun + :handles)) (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 - (completion-table-dynamic ; only search when necessary: - (lambda (_) - ;; Interruptible candidate computation, from minad/d mendler, thanks! - (let ((result - (while-no-input - (mastodon-toot--fetch-completion-candidates start end :tags)))) - (and (consp result) result)))) - :exclusive 'no - :annotation-function - (lambda (cand) - (concat " " (mastodon-toot--tags-annotation-fun cand))))))) + (mastodon-toot--make-capf mastodon-toot-tag-regex + #'mastodon-toot--tags-annotation-fun + :tags)) + +(defun mastodon-toot--emoji-capf () + "Build an emoji completion backend for `completion-at-point-functions'." + (mastodon-toot--make-capf mastodon-toot-emoji-regex + #'mastodon-toot--emoji-annotation-fun + :emoji)) (defun mastodon-toot--mentions-annotation-fun (candidate) "Given a handle completion CANDIDATE, return its annotation string, a username." @@ -1062,16 +1100,26 @@ If TAGS, we search for tags, else we search for handles." ;; or make it an alist and use cdr (cadr (assoc candidate mastodon-toot-completions))) +(defun mastodon-toot--emoji-annotation-fun (_candidate) + "." + ;; TODO: emoji image as annot + ) + ;;; REPLY (defun mastodon-toot--reply () "Reply to toot at `point'. Customize `mastodon-toot-display-orig-in-reply-buffer' to display -text of the toot being replied to in the compose buffer." +text of the toot being replied to in the compose buffer. +If the region is active, inject it into the reply buffer, +prefixed by >." (interactive) (mastodon-tl--do-if-item-strict - (let* ((toot (mastodon-tl--property 'item-json)) + (let* ((quote (when (region-active-p) + (buffer-substring (region-beginning) + (region-end)))) + (toot (mastodon-tl--property 'item-json)) ;; no-move arg for base toot: don't try next toot (base-toot (mastodon-tl--property 'base-toot :no-move)) ; for new notifs handling (id (mastodon-tl--as-string (mastodon-tl--field 'id (or base-toot toot)))) @@ -1082,7 +1130,7 @@ text of the toot being replied to in the compose buffer." (booster (when boosted (alist-get 'acct (alist-get 'account toot))))) - (mastodon-toot + (mastodon-toot--compose-buffer (when user (if booster (if (and (not (equal user booster)) @@ -1102,7 +1150,8 @@ text of the toot being replied to in the compose buffer." ;; user in mentions already: (mastodon-toot--mentions-to-string (copy-sequence mentions))))) id - (or base-toot toot))))) + (or base-toot toot) + quote)))) ;;; COMPOSE TOOT SETTINGS @@ -1178,7 +1227,32 @@ File is actually attached to the toot upon posting." (:filename . ,file))))) (mastodon-toot--refresh-attachments-display) ;; upload only most recent attachment: - (mastodon-toot--upload-attached-media (car (last mastodon-toot--media-attachments))))) + (mastodon-toot--upload-attached-media + (car (last mastodon-toot--media-attachments))))) + +(defun mastodon-toot--attachment-descriptions () + "Return a list of image descriptions for current attachments." + (mapcar (lambda (a) + (alist-get :description a)) + mastodon-toot--media-attachments)) + +(defun mastodon-toot--attachment-from-desc (desc) + "Return an attachment based on its description DESC." + (car + (cl-member-if (lambda (x) + (rassoc desc x)) + mastodon-toot--media-attachments))) + +(defun mastodon-toot--edit-media-description () + "Prompt for an attachment, and update its description." + (interactive) + (let* ((descs (mastodon-toot--attachment-descriptions)) + (choice (completing-read "Attachment: " descs nil :match)) + (attachment (mastodon-toot--attachment-from-desc choice)) + (desc-new (read-string "Description: " choice))) + (setf (alist-get :description attachment) + desc-new) + (mastodon-toot--refresh-attachments-display))) (defun mastodon-toot--upload-attached-media (attachment) "Upload a single ATTACHMENT using `mastodon-http--post-media-attachment'. @@ -1519,16 +1593,45 @@ The default is given by `mastodon-toot--default-reply-visibility'." (if (member (intern reply-visibility) less-restrictive) mastodon-toot--default-reply-visibility reply-visibility)))) -(defun mastodon-toot--setup-as-reply (reply-to-user reply-to-id reply-json) +(defun mastodon-toot--fill-buffer () + "Mark buffer, call `fill-region'." + (mark-whole-buffer) ; lisp code should not set mark + ;; (fill-region (point-min) (point-max)) ; but this doesn't work + (fill-region (region-beginning) (region-end))) + +(defun mastodon-toot--render-reply-region-str (str) + "Refill STR and prefix all lines with >, as reply-quote text." + (with-temp-buffer + ;; (switch-to-buffer (current-buffer)) + (insert str) + ;; unfill first: + (let ((fill-column (point-max))) + (mastodon-toot--fill-buffer)) + ;; then fill: + (mastodon-toot--fill-buffer) + ;; add our own prefix, pauschal: + (save-match-data + (while (re-search-forward "^" nil t) + (replace-match " > "))) + (buffer-substring-no-properties (point-min) + (point-max)))) + +(defun mastodon-toot--setup-as-reply (reply-to-user reply-to-id + reply-json reply-region) "If REPLY-TO-USER is provided, inject their handle into the message. If REPLY-TO-ID is provided, set `mastodon-toot--reply-to-id'. -REPLY-JSON is the full JSON of the toot being replied to." +REPLY-JSON is the full JSON of the toot being replied to. +REPLY-REGION is a string to be injected into the buffer." (let ((reply-visibility (mastodon-toot--most-restrictive-visibility (alist-get 'visibility reply-json))) (reply-cw (alist-get 'spoiler_text reply-json))) (when reply-to-user (when (> (length reply-to-user) 0) ; self is "" unforch (insert (format "%s " reply-to-user))) + (when reply-region + (insert "\n" + (mastodon-toot--render-reply-region-str reply-region) + "\n")) (setq mastodon-toot--reply-to-id reply-to-id) (unless (equal mastodon-toot--visibility reply-visibility) (setq mastodon-toot--visibility reply-visibility)) @@ -1749,18 +1852,23 @@ EDIT means we are editing an existing toot, not composing a new one." ;; perhaps we should not always call --setup-as-reply, or make its ;; workings conditional on reply-to-id. currently it only checks for ;; reply-to-user. - (mastodon-toot--setup-as-reply reply-to-user reply-to-id reply-json)) + (mastodon-toot--setup-as-reply reply-to-user reply-to-id reply-json + ;; only initial-text if reply (not edit): + (when reply-json initial-text))) (unless mastodon-toot--max-toot-chars ;; 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 completion: + (setq-local completion-ignore-case t) (when mastodon-toot--enable-completion (set (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) + (add-to-list 'completion-at-point-functions + #'mastodon-toot--emoji-capf) ;; company (when (and mastodon-toot--use-company-for-completion (require 'company nil :no-error)) @@ -1782,7 +1890,8 @@ EDIT means we are editing an existing toot, not composing a new one." (setq mastodon-toot-previous-window-config previous-window-config) (when mastodon-toot--proportional-fonts-compose (facemenu-set-face 'variable-pitch)) - (when initial-text + (when (and initial-text + (not reply-json)) (insert initial-text)))) ;; flyspell ignore masto toot regexes: |