diff options
Diffstat (limited to 'lisp/mastodon-tl.el')
| -rw-r--r-- | lisp/mastodon-tl.el | 265 |
1 files changed, 186 insertions, 79 deletions
diff --git a/lisp/mastodon-tl.el b/lisp/mastodon-tl.el index 41ecd85..8c00418 100644 --- a/lisp/mastodon-tl.el +++ b/lisp/mastodon-tl.el @@ -89,6 +89,8 @@ (autoload 'mastodon-search--insert-heading "mastodon-search") (autoload 'mastodon-media--process-full-sized-image-response "mastodon-media") (autoload 'mastodon-search--trending-statuses "mastodon-search") +(autoload 'mastodon-search--format-heading "mastodon-search") +(autoload 'mastodon-toot--with-toot-item "mastodon-toot") (defvar mastodon-toot--visibility) (defvar mastodon-toot-mode) @@ -219,6 +221,13 @@ respects the user's `browse-url' settings." See `mastodon-tl--get-remote-local-timeline' for view remote local domains." :type '(repeat string)) + +(defcustom mastodon-tl--fold-toots-at-length 1200 + "Length, in characters, to fold a toot at. +Longer toots will be folded and the remainder replaced by a +\"read more\" button. If the value is nil, don't fold at all." + :type '(integer)) + ;;; VARIABLES @@ -239,9 +248,8 @@ If nil `(point-min)' is used instead.") "The timer that, when set will scan the buffer to update the timestamps.") (defvar mastodon-tl--horiz-bar - (if (char-displayable-p ?―) - (make-string 12 ?―) - (make-string 12 ?-))) + (make-string 12 + (if (char-displayable-p ?―) ?― ?-))) ;;; KEYMAPS @@ -339,14 +347,6 @@ than `pop-to-buffer'." (message "Looks like there's no item at point?") ,@body)) -(defmacro mastodon-tl--do-if-item-strict (&rest body) - "Execute BODY if we have a toot object at point. -Includes boosts, and notifications that display toots." - (declare (debug t)) - `(if (not (equal 'toot (mastodon-tl--property 'item-type :no-move))) - (message "Looks like there's no toot at point?") - ,@body)) - ;;; NAV @@ -404,14 +404,18 @@ Optionally start from POS." (current-buffer)))) (if npos (if (not - ;; (get-text-property npos 'item-id) ; toots, users, not tags (get-text-property npos 'item-type)) ; generic + ;; FIXME let's make refresh &optional and only call refresh/recur + ;; if non-nil: (mastodon-tl--goto-item-pos find-pos refresh npos) (goto-char npos) ;; force display of help-echo on moving to a toot byline: (mastodon-tl--message-help-echo)) - ;; FIXME: this doesn't work, as the funcall doesn't return if we - ;; run into an endless refresh loop + ;; FIXME: doesn't work, the funcall doesn't return if in an endless + ;; refresh loop. + ;; either let-bind `max-lisp-eval-depth' and try to error handle when it + ;; errors, or else set up a counter, and error when it gets to high + ;; (like >2 would already be too much) (condition-case nil (funcall refresh) (error "No more items"))))) @@ -984,6 +988,8 @@ the toot)." LINK-TYPE is the type of link to produce." (let ((help-text (cond ((eq link-type 'content-warning) "Toggle hidden text") + ((eq link-type 'read-more) + "Toggle full post") (t (error "Unknown link type %s" link-type))))) (propertize string @@ -1025,6 +1031,8 @@ Used for hitting RET on a given link." "Search for account returned nothing. Perform URL lookup?") (mastodon-url-lookup (get-text-property position 'shr-url)) (message "Unable to find account.")))))))) + ((eq link-type 'read-more) + (mastodon-tl--unfold-post)) (t (error "Unknown link type %s" link-type))))) @@ -1365,7 +1373,7 @@ displayed when the duration is smaller than a minute)." cell)) options-alist))) (if (null poll) - (message "No poll here.") + (user-error "No poll here") (list ;; var "option" = just the cdr, a cons of option number and desc (cdr (assoc (completing-read "Poll option to vote for: " @@ -1377,7 +1385,7 @@ displayed when the duration is smaller than a minute)." "If there is a poll at point, prompt user for OPTION to vote on it." (interactive (mastodon-tl--read-poll-option)) (if (null (mastodon-tl--field 'poll (mastodon-tl--property 'item-json))) - (message "No poll here.") + (user-error "No poll here") (let* ((toot (mastodon-tl--property 'item-json)) (poll (mastodon-tl--field 'poll toot)) (poll-id (alist-get 'id poll)) @@ -1486,11 +1494,11 @@ Runs `mastodon-tl--render-text' and fetches poll or media." "Return the id of the last toot inserted into the buffer." (let* ((prev-change (save-excursion - (previous-single-property-change (point) 'base-toot-id))) + (previous-single-property-change (point) 'base-item-id))) (prev-pos (when prev-change (1- prev-change)))) (when prev-pos - (get-text-property prev-pos 'base-toot-id)))) + (get-text-property prev-pos 'base-item-id)))) (defun mastodon-tl--after-reply-status (reply-to-id) "T if REPLY-TO-ID is equal to that of the last toot inserted in the bufer." @@ -1498,7 +1506,8 @@ Runs `mastodon-tl--render-text' and fetches poll or media." (string= reply-to-id prev-id))) (defun mastodon-tl--insert-status (toot body author-byline action-byline - &optional id base-toot detailed-p thread domain) + &optional id base-toot detailed-p + thread domain unfolded no-byline) "Display the content and byline of timeline element TOOT. BODY will form the section of the toot above the byline. AUTHOR-BYLINE is an optional function for adding the author @@ -1515,31 +1524,46 @@ JSON of the toot responded to. DETAILED-P means display more detailed info. For now this just means displaying toot client. THREAD means the status will be displayed in a thread view. -When DOMAIN, force inclusion of user's domain in their handle." +When DOMAIN, force inclusion of user's domain in their handle. +UNFOLDED is a boolean meaning whether to unfold or fold item if foldable. +NO-BYLINE means just insert toot body, used for folding." (let* ((start-pos (point)) (reply-to-id (alist-get 'in_reply_to_id toot)) (after-reply-status-p (when (and thread reply-to-id) (mastodon-tl--after-reply-status reply-to-id))) - (type (alist-get 'type toot))) - ;; body: + (type (alist-get 'type toot)) + (toot-foldable + (and mastodon-tl--fold-toots-at-length + (length> body mastodon-tl--fold-toots-at-length)))) (insert (propertize (concat - "\n" - (if (and after-reply-status-p thread) - (concat (mastodon-tl--symbol 'replied) - "\n") - "") - (if (and after-reply-status-p thread) - (let ((bar (mastodon-tl--symbol 'reply-bar))) - (propertize body - 'line-prefix bar - 'wrap-prefix bar)) - body) - " \n" + (propertize + (concat + "\n" + ;; relpy symbol (broken): + (if (and after-reply-status-p thread) + (concat (mastodon-tl--symbol 'replied) + "\n") + "") + ;; actual body: + (let ((bar (mastodon-tl--symbol 'reply-bar)) + (body (if (and toot-foldable (not unfolded)) + (mastodon-tl--fold-body body) + body))) + (if (and after-reply-status-p thread) + (propertize body + 'line-prefix bar + 'wrap-prefix bar) + body))) + 'toot-body t) ;; includes newlines etc. for folding ;; byline: - (mastodon-tl--byline toot author-byline action-byline detailed-p domain)) + "\n" + (if no-byline + "" + (mastodon-tl--byline toot author-byline action-byline + detailed-p domain))) 'item-type 'toot 'item-id (or id ; notification's own id (alist-get 'id toot)) ; toot id @@ -1551,11 +1575,87 @@ When DOMAIN, force inclusion of user's domain in their handle." 'item-json toot 'base-toot base-toot 'cursor-face 'mastodon-cursor-highlight-face - 'notification-type type) - "\n") + 'notification-type type + 'toot-foldable toot-foldable + 'toot-folded (and toot-foldable (not unfolded))) + (if no-byline "" "\n")) (when mastodon-tl--display-media-p (mastodon-media--inline-images start-pos (point))))) +(defun mastodon-tl--fold-body (body) + "Fold toot BODY if it is very long. +Folding decided by `mastodon-tl--fold-toots-at-length'." + (let* ((heading (mastodon-search--format-heading + (mastodon-tl--make-link "READ MORE" 'read-more) + nil :no-newline)) + (display (concat (substring body 0 + mastodon-tl--fold-toots-at-length) + heading))) + (propertize display + 'read-more body))) + +(defun mastodon-tl--unfold-post (&optional fold) + "Unfold the toot at point if it is folded (read-more). +FOLD means to fold it instead" + (interactive) + (let ((at-byline (mastodon-tl--property 'byline :no-move))) + (if (save-excursion + (when (not at-byline) + (mastodon-tl--goto-next-item)) + (not (mastodon-tl--property 'toot-foldable :no-move))) + (user-error "No foldable item at point?") + (let* ((inhibit-read-only t) + (body-range (mastodon-tl--find-property-range 'toot-body + (point) :backward)) + (toot (mastodon-tl--property 'item-json :no-move)) + ;; `replace-region-contents' is much too slow, our hack from + ;; fedi.el is much simpler and much faster: + (beg (car body-range)) + (end (cdr body-range)) + (last-point (point)) + (point-after-fold (> last-point + (+ beg mastodon-tl--fold-toots-at-length)))) + ;; save-excursion here useless actually: + + ;; FIXME: because point goes to top of item, the screen gets scrolled + ;; by insertion + (goto-char beg) + (delete-region beg end) + (delete-char 1) ;; prevent newlines accumulating + ;; insert toot body: + (mastodon-tl--toot toot nil nil nil + (not fold) ;; (if fold :folded :unfolded) + :no-byline) + ;; set toot-folded prop on entire toot (not just body): + (let ((toot-range ;; post fold action range: + (mastodon-tl--find-property-range 'item-json + (point) :backward))) + (add-text-properties (car toot-range) + (cdr toot-range) + `(toot-folded ,fold))) + ;; try to leave point somewhere sane: + (cond ((or at-byline + (and fold + point-after-fold)) ;; point was in area now folded + (ignore-errors (forward-line -1)) ;; in case we are btw + (mastodon-tl--goto-next-item)) ;; goto byline + (t + (goto-char last-point) + (when point-after-fold ;; point was in READ MORE heading: + (beginning-of-line)))) + (message (format "%s" (if fold "Fold" "Unfold"))))))) + +(defun mastodon-tl--fold-post () + "Fold post at point, if it is too long." + (interactive) + (mastodon-tl--unfold-post t)) + +(defun mastodon-tl--fold-post-toggle () + "Toggle the folding status of the toot at point." + (interactive) + (let* ((folded (mastodon-tl--property 'toot-folded :no-move))) + (mastodon-tl--unfold-post (not folded)))) + ;; from mastodon-alt.el: (defun mastodon-tl--toot-for-stats (&optional toot) "Return the TOOT on which we want to extract stats. @@ -1616,19 +1716,22 @@ To disable showing the stats, customize (and (null (mastodon-tl--field 'in_reply_to_id toot)) (not (mastodon-tl--field 'rebloged toot)))) -(defun mastodon-tl--toot (toot &optional detailed-p thread domain) +(defun mastodon-tl--toot (toot &optional detailed-p thread domain + unfolded no-byline) "Format TOOT and insert it into the buffer. DETAILED-P means display more detailed info. For now this just means displaying toot client. THREAD means the status will be displayed in a thread view. -When DOMAIN, force inclusion of user's domain in their handle." +When DOMAIN, force inclusion of user's domain in their handle. +UNFOLDED is a boolean meaning whether to unfold or fold item if foldable. +NO-BYLINE means just insert toot body, used for folding." (mastodon-tl--insert-status toot (mastodon-tl--clean-tabs-and-nl (if (mastodon-tl--has-spoiler toot) (mastodon-tl--spoiler toot) (mastodon-tl--content toot))) 'mastodon-tl--byline-author 'mastodon-tl--byline-boosted - nil nil detailed-p thread domain)) + nil nil detailed-p thread domain unfolded no-byline)) (defun mastodon-tl--timeline (toots &optional thread domain) "Display each toot in TOOTS. @@ -1961,7 +2064,7 @@ ID is that of the toot to view." #'mastodon-tl--update-toot) (mastodon-tl--toot toot :detailed-p) (goto-char (point-min)) - (mastodon-tl--goto-next-item))))) + (mastodon-tl--goto-next-item :no-refresh))))) (defun mastodon-tl--update-toot (json) "Call `mastodon-tl--single-toot' on id found in JSON." @@ -1980,45 +2083,49 @@ view all branches of a thread." (let ((id (mastodon-tl--property 'base-item-id))) (mastodon-tl--thread id)))) -(defun mastodon-tl--thread (&optional id) - "Open thread buffer for toot at point or with ID." +(defun mastodon-tl--thread (&optional thread-id) + "Open thread buffer for toot at point or with THREAD-ID." (interactive) - (let* ((id (or id (mastodon-tl--property 'base-item-id :no-move))) - (type (mastodon-tl--field 'type (mastodon-tl--property 'item-json :no-move)))) - (if (or (string= type "follow_request") - (string= type "follow")) ; no can thread these - (user-error "No thread") - (let* ((endpoint (format "statuses/%s/context" id)) - (url (mastodon-http--api endpoint)) - (buffer (format "*mastodon-thread-%s*" id)) - (toot (mastodon-http--get-json ; refetch in case we just faved/boosted: - (mastodon-http--api (concat "statuses/" id)) - nil :silent)) - (context (mastodon-http--get-json url nil :silent))) - (if (equal (caar toot) 'error) - (user-error "Error: %s" (cdar toot)) - (when (member (alist-get 'type toot) '("reblog" "favourite")) - (setq toot (alist-get 'status toot))) - (if (> (+ (length (alist-get 'ancestors context)) - (length (alist-get 'descendants context))) - 0) - ;; if we have a thread: - (with-mastodon-buffer buffer #'mastodon-mode nil - (let ((marker (make-marker))) - (mastodon-tl--set-buffer-spec buffer endpoint - #'mastodon-tl--thread) - (mastodon-tl--timeline (alist-get 'ancestors context) :thread) - (goto-char (point-max)) - (move-marker marker (point)) - ;; print re-fetched toot: - (mastodon-tl--toot toot :detailed-p :thread) - (mastodon-tl--timeline (alist-get 'descendants context) - :thread) - ;; put point at the toot: - (goto-char (marker-position marker)) - (mastodon-tl--goto-next-item))) - ;; else just print the lone toot: - (mastodon-tl--single-toot id))))))) + (mastodon-toot--with-toot-item + ;; this function's var must not be id as the above macro binds id and even + ;; if we provide the arg (e.g. url-lookup), the macro definition overrides + ;; it, making the optional arg unusable! + (let* ((id (or thread-id (mastodon-tl--property 'base-item-id :no-move))) + (type (mastodon-tl--field 'type (mastodon-tl--property 'item-json :no-move)))) + (if (or (string= type "follow_request") + (string= type "follow")) ; no can thread these + (user-error "No thread") + (let* ((endpoint (format "statuses/%s/context" id)) + (url (mastodon-http--api endpoint)) + (buffer (format "*mastodon-thread-%s*" id)) + (toot (mastodon-http--get-json ; refetch in case we just faved/boosted: + (mastodon-http--api (concat "statuses/" id)) + nil :silent)) + (context (mastodon-http--get-json url nil :silent))) + (if (equal (caar toot) 'error) + (user-error "Error: %s" (cdar toot)) + (when (member (alist-get 'type toot) '("reblog" "favourite")) + (setq toot (alist-get 'status toot))) + (if (> (+ (length (alist-get 'ancestors context)) + (length (alist-get 'descendants context))) + 0) + ;; if we have a thread: + (with-mastodon-buffer buffer #'mastodon-mode nil + (let ((marker (make-marker))) + (mastodon-tl--set-buffer-spec buffer endpoint + #'mastodon-tl--thread) + (mastodon-tl--timeline (alist-get 'ancestors context) :thread) + (goto-char (point-max)) + (move-marker marker (point)) + ;; print re-fetched toot: + (mastodon-tl--toot toot :detailed-p :thread) + (mastodon-tl--timeline (alist-get 'descendants context) + :thread) + ;; put point at the toot: + (goto-char (marker-position marker)) + (mastodon-tl--goto-next-item))) + ;; else just print the lone toot: + (mastodon-tl--single-toot id)))))))) (defun mastodon-tl--mute-thread () "Mute the thread displayed in the current buffer. |