Merge branch 'develop'

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.