sharkey-el/sharkey.el

;;; sharkey.el --- mir playing around with mastodon.el and sharkey and stuff

(use-package mastodon
  :ensure t
  :custom
  (mastodon-active-user "@mir")
  (mastodon-instance-url "https://talk.marq42.xyz")
  (mastodon-tl--show-avatars t)
  (mastodon-toot--enable-custom-instance-emoji t)
  (mastodon-use-emojify t)
  (image-use-external-converter t)
  :demand)

;; 日本語

(require 'shr)

;; need to figure out custom emoji resolution

;; let's start by making :rena: render as the rena.webp image...

:neocat_pat_floof::3:
(defvar sharkey/emoji-cache-dir "~/.emoji"
  "Directory under which to store fedi emoji cache.")
(defun sharkey--emoji-cache (name &optional instance)
  "Given remote emoji called NAME, return its local path.
INSTANCE defaults to `mastodon-instance-url'.

returns nil if such an emoji does not exist."
  (let* ((instance (or instance mastodon-instance-url))
	 (plain-instance (string-trim instance "https://"))
	 (plain-name			; should start in colons, remove those
	  (string-trim name ":" ":"))
	 (url (format "%s/emoji/%s.webp" instance plain-name))
	 (local-path (format "%s/%s/%s.webp"
			     sharkey/emoji-cache-dir
			     plain-instance
			     plain-name)))
    (unless (file-exists-p local-path)
      ;; can we do this lazy, like with timers or sth? ehh it's plenty fast as is...
      (mkdir (file-name-directory local-path) 'p)
      (url-copy-file url local-path))
    (if (eq 'webp (image-type-from-file-header local-path))
	local-path
      nil)))
;; (image-type-from-file-header "~/rena.webp")
:skull:
;; (sharkey--emoji-cache ":rena:")
;; (window-font-height)
;; (insert-image (create-image (sharkey--emoji-cache ":rena:") nil nil
;; 			    :height (window-font-height)
;; 			    :ascent 'center))

(defvar sharkey/emoji-rx (rx (group-n 1 ":" (+ (or alnum "-" "_")) ":")))
(defun next-emoji-overlay (&optional limit)
  ;; adapted from https://kitchingroup.cheme.cmu.edu/blog/2016/03/21/Displaying-image-overlays-on-image-filenames-in-Emacs/ -- specifically the latter section on overlays
  "Turn the next occurence of a colon-delimited emoji name (within LIMIT) into the emoji itself, using an overlay."
  (ignore-errors
    ;; needs to be `while'. it was `when' and that caused problems.
    (while (re-search-forward sharkey/emoji-rx limit t)
      (let* ((beg (match-beginning 0))
             (end (match-end 0))
             (emoj (match-string 1))
	     (img (create-image (sharkey--emoji-cache emoj)
				(if (image-type-available-p 'imagemagick)
				    'imagemagick
				  'webp)
				nil
				:height (window-font-height)
				:ascent 'center))
	     (ov (make-overlay beg end)))
	(image-animate img nil t)
	(overlay-put ov 'display img)
	;; (overlay-put ov 'face 'default)
	(overlay-put ov 'help-echo emoj)
	(overlay-put ov 'org-image-overlay t)
	(overlay-put ov 'modification-hooks
		     (list 'org-display-inline-remove-overlay))))))
(defvar sharkey/small-rx
  ;; this might display a bit weird... sorgy
  (rx (group-n 1 "<small>")
      (group-n 2 (+? (or "\n" any)))
      (group-n 3 "</small>")))
(defun next-small-overlay (&optional limit)
  "logic from `next-emoji-overlay' but for mfm <small></small> tag."
  (while (re-search-forward sharkey/small-rx limit t)
    (let* ((openr-beg (match-beginning 1))
	   (openr-end (match-end 1))
	   (text-beg (match-beginning 2))
	   (text-end (match-end 2))
	   (close-beg (match-beginning 3))
	   (close-end (match-end 3))
	   (placehoverlay (make-overlay openr-beg close-end))
	   (openr-ov (make-overlay openr-beg openr-end))
	   (close-ov (make-overlay close-beg close-end))
	   (text (buffer-substring text-beg text-end))
	   (text-ov (make-overlay text-beg text-end))
	   )
      (overlay-put openr-ov 'display "")
      (overlay-put close-ov 'display "")
      ;; (put-text-property openr-beg openr-end 'invisible t)
      ;; (put-text-property close-beg close-end 'invisible t)
      ;; (overlay-put text-ov 'help-echo text)
      ;; (put-text-property text-beg text-end 'display '(height 0.8))
      (overlay-put placehoverlay 'display '(height 0.8))
      (overlay-put placehoverlay 'mfm-tag "small")
      (overlay-put placehoverlay 'modification-hooks
		   (list
		    'mir/remove-all-overlays
		    'org-display-inline-remove-overlay))
      (overlay-put openr-ov 'modification-hooks
		   (list 'org-display-inline-remove-overlay))
      (overlay-put close-ov 'modification-hooks
		   (list 'org-display-inline-remove-overlay))
	;; (overlay-put openr-ov 'org-image-overlay t)
	;; (overlay-put close-ov 'org-image-overlay t)
	;; (overlay-put text-ov  'org-image-overlay t)
      )))
(defun mir/remove-all-overlays (&optional overlay nyl beg end)
  "Delete all overlays resting on current line."
  ;; (message "%s" throwaway)
  ;; ^^^--> list of overlay, nil, bounds
  (let* ((start-bound (or beg (pos-bol)))
	 (end-bound (or end (pos-eol))))
    (--map
     (mapcar #'delete-overlay (overlays-at it))
     (number-sequence start-bound end-bound)))
  nil)
(defun mir/overlay-bounds (overlay)
  "Return a cons of `(start . end)' for OVERLAY."
  (cons
   (overlay-start overlay)
   (overlay-end overlay)))
(defface mfm-delimiter-invis-face
  '((t (:string "")))
  "Face for misskey markdown elements such as <small\> type stuff.")

;; the fact is, <small>this :neofox: is <small>extra</small> smol</small> <-- she should render double small
;; <small>this :neocat: is also smol</small apparently

(font-lock-add-keywords
 nil					; this must needs be nil
 `((next-emoji-overlay (0  'font-lock-keyword-face t))
   (next-small-overlay (0  'font-lock-keyword-face t))
   ;; (,sharkey/small-rx 1 'mfm-delimiter-invis-face t)
   ;; (,sharkey/small-rx 3 'mfm-delimiter-invis-face t)
   ) t)

(define-minor-mode fedimoji-mode
  "Display colon-delimited fediverse emoji properly."
  (font-lock-add-keywords
   nil ; no really, it has to be nil
   '((next-emoji-overlay
      (0  'font-lock-keyword-face t)))
   t)
  )
(add-hook 'mastodon-mode #'fedimoji-mode)
(add-hook 'mastodon-toot-mode-hook #'fedimoji-mode)
;; ":neofox:" <-- this fucking fox is breaking my syntax highlighting
;; can we do animated? :nixos-3d:
;; apparently so... :silvervale_waves:

;; (defun mfm-render (input)
;;   "Convert INPUT plain text to propertized rich text using the implemented set of misskey flavored markdown."
;;   (--> input
;;        (string-replace )))

;; default from mastodon.el - how can we destroy it?
(defun mastodon-tl--insert-status (toot body author-byline action-byline
                                        &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
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 status if it is a notification, which is
attached as a `item-id' property if provided. If the
status is a favourite or boost notification, BASE-TOOT is the
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.
UNFOLDED is a boolean meaning whether to unfold or fold item if foldable.
NO-BYLINE means just insert toot body, used for folding."
  ;; (message "toot: %s" (pp toot)) ; good for debug?
  (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))
         (toot-foldable
          (and mastodon-tl--fold-toots-at-length
               (length> body mastodon-tl--fold-toots-at-length)))
	 ;; a mir addition:
	 (toot-char-width
	  (min
	   (max
	    (apply #'max (--map (length it)
				(split-string body "\n")))
	    ;; o thank gosh, max can take one arg
	    ;; want to add image width when figure out how
	    )
	   (window-width nil 'remap)))
	 )
    (insert
     (propertize
      (concat
       ;; byline:
       "\n"
       (if no-byline
           ""
         (mastodon-tl--byline toot author-byline action-byline
			      detailed-p domain))
       (propertize
	(concat
	 ;; mir: box draw at top of post
	 "┏"
	 (make-string (- toot-char-width 2) ?━)
	 "┓"
	 "\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))
		;; mir addition: we need emoji processing
		(simplified-emoji-alist
		 (--map (cons (alist-get 'shortcode it)
			      (alist-get 'url it))
			(alist-get 'emojis toot)) )
		(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)
	     ;; (message "%s" simplified-emoji-alist)
	     body))
	 (concat "\n┗" (make-string (- toot-char-width 2) ?━) "┛")
	 )
	'toot-body t) ;; includes newlines etc. for folding
       )
      'item-type    'toot
      'item-id      (or id		      ; notification's own id
			(alist-get 'id toot)) ; toot id
      'base-item-id (mastodon-tl--item-id
		     ;; if status is a notif, get id from base-toot
		     ;; (-tl--item-id toot) will not work here:
		     (or base-toot
			 toot))		; else normal toot with reblog check
      'item-json    toot
      'base-toot    base-toot
      'cursor-face 'mastodon-cursor-highlight-face
      '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)))
    ))

;; stolen and modified from the placey thing :3
(defun mastodon-tl--byline (toot author-byline action-byline &optional detailed-p domain)
  "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.
When DOMAIN, force inclusion of user's domain in their handle."
  (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)))
         (visibility (mastodon-tl--field 'visibility toot))
         (account (alist-get 'account toot))
         (avatar-url (alist-get 'avatar account))
         (type (alist-get 'type toot))
         (edited-time (alist-get 'edited_at toot))
         (edited-parsed (when edited-time (date-to-time edited-time))))
    (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-item' 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
                (mastodon-tl--symbol 'boost)))
             (when faved
               (mastodon-tl--format-faved-or-boosted-byline
                (mastodon-tl--symbol 'favourite)))
             (when bookmarked
               (mastodon-tl--format-faved-or-boosted-byline
                (mastodon-tl--symbol 'bookmark))))
     ;; we remove avatars from the byline also, so that they also do not mess
     ;; with `mastodon-tl--goto-next-item':
     (when (and mastodon-tl--show-avatars
                mastodon-tl--display-media-p
                (if (version< emacs-version "27.1")
                    (image-type-available-p 'imagemagick)
                  (image-transforms-p)))
       (mastodon-media--get-avatar-rendering avatar-url))
     (propertize
      (concat
       ;; we propertize help-echo format faves for author name
       ;; in `mastodon-tl--byline-author'
       (funcall author-byline toot nil domain)
       ;; visibility:
       (cond ((equal visibility "direct")
              (propertize (concat " " (mastodon-tl--symbol 'direct))
                          'help-echo visibility))
             ((equal visibility "private")
              (propertize (concat " " (mastodon-tl--symbol 'private))
                          'help-echo visibility)))
       (funcall action-byline toot)
       " "
       (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)))))
       (if edited-time
           (concat
            " "
            (mastodon-tl--symbol 'edited)
            " "
            (propertize
             (format-time-string mastodon-toot-timestamp-format
                                 edited-parsed)
             'face 'font-lock-comment-face
             'timestamp edited-parsed
             'display (if mastodon-tl--enable-relative-timestamps
                          (mastodon-tl--relative-time-description edited-parsed)
                        edited-parsed)))
         "")
       (propertize (concat "\n  " mastodon-tl--horiz-bar)
                   'face 'default)
       (if (and mastodon-tl--show-stats
                (not (member type '("follow" "follow_request"))))
           (mastodon-tl--toot-stats toot)
         "")
       "\n")
      'favourited-p faved
      'boosted-p    boosted
      'bookmarked-p bookmarked
      'edited edited-time
      'edit-history (when edited-time
                      (mastodon-toot--get-toot-edits (alist-get 'id toot)))
      'byline       t))))