Emacs Mastodon client mockup

gistfile1.txt

;;; init-mastodon.el --- Mastodon layout mockup -*- lexical-binding: t -*-

;; Copyright (C) 2022 Nicolas P. Rougier

;; This file is not part of GNU Emacs.

;; This file is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 3, or (at your option)
;; any later version.

;; This file is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; For a full copy of the GNU General Public License
;; see <https://www.gnu.org/licenses/>.

;;; Commentary:

;; Work in progress ( = dirty code, may break at any point...)

;;; Code:
(require 'mastodon)
(require 'nano-theme) ;; not striclty necessary

(defface mastodon-read-face
  `((t :inherit font-lock-comment-face))
  "Face for read toots."
  :group 'mastodon)

(defface mastodon-separator-face
  `((t :inherit font-lock-comment-face))
  "Face for line separating toots."
  :group 'mastodon)

(defface mastodon-status-face
  `((t :inherit font-lock-comment-face))
  "Face for toot status (below separator)."
  :group 'mastodon)

(defcustom mastodon-show-toot-action t
  "Whether to show toot action menu."
  :group 'mastodon)

(defcustom mastodon-show-toot-separator t
  "Whether to show separatino between toots."
  :group 'mastodon)

(defcustom mastodon-show-toot-status t
  "Whether to show toot status."
  :group 'mastodon)

(defcustom mastodon-shorten-url t
  "Whether to shorten url in toots."
  :group 'mastodon)

(defcustom mastodon-box-boosted t
  "Whether to enclose boosted toots in a text box."
  :group 'mastodon)

(defcustom mastodon-symbols '((reply     . "")
                              (boost     . "")
                              (favourite . "")
                              (bookmark  . "")
                              (media     . ""))
  "Set of symbols or strings to be used for displaying toot status")


(defvar mastodon--overlay-home nil
  "Overaly for read toots in the home feed.")

(defvar mastodon--overlay-local nil
  "Overaly for read toots in the local feed.")

(defvar mastodon--overlay-federated nil
  "Overaly for read toots in the federated feed.") 

(defun mastodon--shorten-url (url)
  "Shorten a url to its domain. For example,
https//github.com/rougier would become [github.com] and the echo help will display the original url and keymap statys untouched."

  (with-temp-buffer
    (insert url)
    (goto-char (point-min))
    (while (search-forward-regexp "\\(\\w+://\\([^/]+\\)[^ \n]*\\)" nil t)
      (replace-match
       (propertize (format "[%s]" (match-string 2))
                   'face 'shr-link
                   'shr-url (match-string 1)
                   'mastodon-tab-stop 'shr-url
                   'keymap mastodon-tl--shr-map-replacement
                   'follow-link t
                   'mouse-face 'highlight
                   'help-echo (format "URL: %s" (match-string 1)))))
    (buffer-substring (point-min) (point-max))))


(defun mastodon--mark-read ()
  "Mark a whole feed (buffer) as read using an overlay. Ideally,
this should be ran just before an update."
  
  (when-let* ((name (buffer-name))
              (feed (when (string-match "\\*mastodon-\\(\\w+\\)\\*" name)
                      (match-string 1 name))))
    (let ((overlay (cond ((string= feed "home")      mastodon--overlay-home)
                         ((string= feed "local")     mastodon--overlay-local)
                         ((string= feed "federated") mastodon--overlay-federated))))
      (unless overlay
        (setf overlay (make-overlay (point-min) (point-max) nil t nil))
        (overlay-put overlay
                     'face '(:inherit mastodon-read-face :extend t)))
      (move-overlay overlay (point-min) (point-max)))))


(defun mastodon--enbox (text &optional size prefix)
  "Enclose TEXT with a unicode box with given SIZE and prefix the
BOX with PREFIX."
  
  (let* ((prefix (or prefix ""))
         (size (or size (- (window-width) 1)))
         (text (with-temp-buffer
                 (insert text)
                 (goto-char (point-min))
                 (let ((fill-column (- size 6))
                       (sentence-end-double-space nil))
                   (fill-region (point-min) (point-max)))
                 (buffer-substring (point-min) (point-max))))
         (line-format (format "%s│ %%s %s│\n" prefix
            (propertize " "  'display `(space :align-to ,(+ size 1))))))
    (concat prefix "┌" (make-string (- size 2) ?─) "┐\n"
            (mapconcat (lambda (line)
                         (format line-format line))
                       (split-string text "[\n]+") "")
            prefix "└" (make-string (- size 2) ?─) "┘")))


;; (set-fontset-font t 'emoji nil)
;; (setq use-default-font-for-symbols nil)
(setq mastodon-tl--display-media-p nil)
(set-fontset-font t 'emoji '("Apple Color Emoji" . "iso10646-1") nil 'prepend)
(set-fontset-font t 'symbol (font-spec :family "Symbola") nil 'prepend)


(defun mastodon-tl--update ()
  "Update timeline with new toots."
  (interactive)
  (mastodon--mark-read)
  (save-excursion
    (let* ((endpoint (mastodon-tl--get-endpoint))
           (update-function (mastodon-tl--get-update-function))
           (id (mastodon-tl--newest-id))
           (json (mastodon-tl--updated-json endpoint id)))
      (when json
        (let ((inhibit-read-only t))
          (goto-char (or mastodon-tl--update-point (point-min)))
          (funcall update-function json))))))


(defun mastodon-tl--more ()
  "Append older toots to timeline, asynchronously."
  (interactive)
  (mastodon--mark-read)
  (save-excursion
  (message "Loading older toots...")
  (if (string= (buffer-name (current-buffer)) "*mastodon-favourites*")
      ;; link-header: can't build a URL with --more-json-async, endpoint/id:
      (let* ((next (car (mastodon-tl--link-header)))
             (prev (cadr (mastodon-tl--link-header)))
             (url (mastodon-tl--build-link-header-url next)))
        (mastodon-http--get-response-async url 'mastodon-tl--more* (current-buffer)
                                           (point) :headers))
    (mastodon-tl--more-json-async (mastodon-tl--get-endpoint) (mastodon-tl--oldest-id)
                                  'mastodon-tl--more* (current-buffer) (point)))))


(defun mastodon-tl--insert-status (toot body author-byline action-byline
                                        &optional id parent-toot detailed-p)
  "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
portion of the byline that takes one variable. By default it is
`mastodon-tl--byline-author'
ACTION-BYLINE is also an optional function for adding an action,
such as boosting favouriting and following to the byline. It also
takes a single function. By default it is
`mastodon-tl--byline-boosted'.

ID is that of the toot, which is attached as a property if it is
a notification. If the status is a favourite or a boost,
PARENT-TOOT is the JSON of the toot responded to.

DETAILED-P means display more detailed info. For now
this just means displaying toot client."
  (let ((start-pos (point))
        (reblog (alist-get 'reblog toot))
        (info (string-trim (or (mastodon-tl--format-faves-count toot) "")))
        (body (mastodon--shorten-url body)))
    (insert
     (propertize
      (concat
       (propertize "\n" 'face '(:extend t
                                :strike-through t
                                :inherit nano-faded))
       (concat (propertize "follow | reply | mute | block" 'face 'nano-faded)
               (propertize " " 'display `(space :align-to (- right ,(+ (length info) 2))))
               (propertize info 'face 'nano-faded)
               "\n\n")
       (if reblog
           (mastodon--enbox body 72 "  ")
         (string-fill body 72))
       (unless (string= (substring body -1) "\n")
           "\n\n")
       (mastodon-tl--byline toot author-byline action-byline detailed-p))
      
      'toot-id      (or id ; for notifications
                        (alist-get 'id toot))
      'base-toot-id (mastodon-tl--toot-id
                     ;; if a favourite/boost notif, get ID of toot responded to:
                     (or parent-toot toot))
      'toot-json    toot
      'parent-toot parent-toot)
     "\n")
    (when mastodon-tl--display-media-p
      (mastodon-media--inline-images start-pos (point)))))



(defun mastodon-tl--format-faves-count (toot)
  "Format a favourites, boosts, replies count for a TOOT.
Used as a help-echo when point is at the start of a byline, i.e.
where `mastodon-tl--goto-next-toot' leaves point. Also displays a
toot's media types and optionally the binding to play moving
image media from the byline."
  (let* ((toot-to-count
          (or
           ;; simply praying this order works
           (alist-get 'status toot) ; notifications timeline
           ;; fol-req notif, has 'type
           ;; placed before boosts coz fol-reqs have a (useless) reblog entry:
           ;; TODO: cd also test for notifs buffer before we do this to be sure
           (when (alist-get 'type toot)
             toot)
           (alist-get 'reblog toot) ; boosts
           toot)) ; everything else
         (fol-req-p (or (string= (alist-get 'type toot-to-count) "follow")
                        (string= (alist-get 'type toot-to-count) "follow_request"))))
    (unless fol-req-p
      (let* ((media-types (mastodon-tl--get-media-types toot))
             (format-faves (format "%s  | %s  | %s "
                                   (alist-get 'favourites_count toot-to-count)
                                   (alist-get 'reblogs_count toot-to-count)
                                   (alist-get 'replies_count toot-to-count)))
             (format-media (when media-types
                             (format " | "
                                     (mapconcat #'identity media-types " "))))
             (format-media-binding (when (and (or
                                               (member "video" media-types)
                                               (member "gifv" media-types))
                                              (require 'mpv nil :no-error))
                                     (format " | C-RET to view with mpv"))))
        (format "%s" (concat format-faves format-media format-media-binding))))))

(defun mastodon-tl--byline (toot author-byline action-byline &optional detailed-p)
  "Generate byline for TOOT.

AUTHOR-BYLINE is a function for adding the author portion of
the byline that takes one variable.
ACTION-BYLINE is a function for adding an action, such as boosting,
favouriting and following to the byline. It also takes a single function.
By default it is `mastodon-tl--byline-boosted'.

DETAILED-P means display more detailed info. For now
this just means displaying toot client."
  (let* ((created-time
          ;; bosts and faves in notifs view
          ;; (makes timestamps be for the original toot
          ;; not the boost/fave):
          (or (mastodon-tl--field 'created_at
                                  (mastodon-tl--field 'status toot))
              ;; all other toots, inc. boosts/faves in timelines:
              ;; (mastodon-tl--field auto fetches from reblogs if needed):
              (mastodon-tl--field 'created_at toot)))
         (parsed-time (date-to-time created-time))
         (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)))
    (concat
     ;; Boosted/favourited markers are not technically part of the byline, so
     ;; we don't propertize them with 'byline t', as per the rest. This
     ;; ensures that `mastodon-tl--goto-next-toot' puts point on
     ;; author-byline, not before the (F) or (B) marker. Not propertizing like
     ;; this makes the behaviour of these markers consistent whether they are
     ;; 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"))
             (when faved
               (mastodon-tl--format-faved-or-boosted-byline "F"))
             (when bookmarked
               (mastodon-tl--format-faved-or-boosted-byline bookmark-str)))
     (propertize
      (concat
       ;; we propertize help-echo format faves for author name
       ;; in `mastodon-tl--byline-author'
       (funcall author-byline toot)
       (cond ((equal visibility "direct")
              (if (fontp (char-displayable-p #10r9993))
                  " ✉"
                " [direct]"))
             ((equal visibility "private")
              (if (fontp (char-displayable-p #10r128274))
                  " 🔒"
                " [followers]")))
       (funcall action-byline toot)
       " "
       ;; TODO: Once we have a view for toot (responses etc.) make
       ;; this a tab stop and attach an action.
       (propertize
        (format-time-string mastodon-toot-timestamp-format parsed-time)
        'timestamp parsed-time
        'display (if mastodon-tl--enable-relative-timestamps
                     (mastodon-tl--relative-time-description parsed-time)
                   parsed-time))
       (when detailed-p
         (let* ((app (alist-get 'application toot))
                (app-name (alist-get 'name app))
                (app-url (alist-get 'website app)))
           (when app
             (concat
              (propertize " via " 'face 'default)
              (propertize app-name
                          'face 'mastodon-display-name-face
                          'follow-link t
                          'mouse-face 'highlight
		          'mastodon-tab-stop 'shr-url
		          'shr-url app-url
                          'help-echo app-url
		          'keymap mastodon-tl--shr-map-replacement)))))
       ;;(propertize "\n  ------------\n" 'face 'default)
       "\n"
       )
      'favourited-p faved
      'boosted-p    boosted
      'bookmarked-p bookmarked
      'byline       t))))