Categories: geek » emacs » elisp

View topic page - RSS - Atom - Subscribe via email

Emacs and dom.el: quick notes on parsing HTML and turning DOMs back into HTML

| elisp

libxml-parse-html-region turns HTML into a DOM (document object model). There's also xml-parse-file and xml-parse-region. xml-parse-string actually parses the character data at point and returns it as a string instead of parsing a string as a parameter. If you have a string and you want to parse it, insert it into a temporary buffer and use libxml-parse-html-region or xml-parse-region.

(let ((s "<span>Hello world</span>")
      dom)
  (setq dom
        (with-temp-buffer
          (insert s)
          (libxml-parse-html-region))))
(html nil (body nil (span nil Hello world)))

Then you can use functions like dom-by-tag, dom-search, dom-attr, dom-children, etc. If you need to make a deep copy of the DOM, you can use copy-tree.

Turning the DOM back into HTML can be a little tricky. By default, dom-print escapes & in attributes, which could mess up things like href:

  (with-temp-buffer
    (dom-print (dom-node 'a '((href . "https://example.com?a=b&c=d"))))
     (buffer-string))
  <a href="https://example.com?a=b&amp;c=d" />

shr-dom-print handles & correctly, but it adds spaces in between elements. Also, you need to escape HTML entities in text, maybe with org-html-encode-plain-text.

  (with-temp-buffer
    (shr-dom-print
      (dom-node 'p nil
                (dom-node 'span nil "hello")
                (dom-node 'span nil "world")
                (dom-node 'a '((href . "https://example.com?a=b&c=d"))
                          (org-html-encode-plain-text "text & stuff"))))
    (buffer-string))
  <p> <span>hello</span> <span>world</span> <a href="https://example.com?a=b&c=d">text &amp; stuff</a></p>

svg-print does the right thing when it comes to href and tags, but you need to escape HTML entities yourself as usual.

(with-temp-buffer
  (svg-print
   (dom-node 'p nil
             (dom-node 'span nil "hello")
             (dom-node 'span nil "world")
             (dom-node 'a '((href . "https://example.com?a=b&c=d"))
                       (org-html-encode-plain-text "text & stuff"))))
  (buffer-string))
  <p><span>hello</span><span>world</span><a href="https://example.com?a=b&c=d">text &amp; stuff</a></p>

Looks like I'll be using svg-print for more than just SVGs.

Relevant Emacs info pages:

View org source for this post

Getting an Org link URL from a string; debugging regex groups

| elisp, org

Sometimes I want to get the URL from a string whether the string contains a bare URL (https://example.com) or an Org bracketed link ([[https://example.com]] or [[https://example.com][Example]], ignoring any extra non-link text (blah https://example.com blah blah). org-link-any-re seemed like the right regular expression to use, but I started to get a little dizzy looking at all the parenthesis and I couldn't figure out which matching group to use. I tried using re-builder. That highlighted the groups in different colours, but I didn't know what the colours meant. All the matching information is in (match-data), but integer pairs can be a little hard to translate back to substrings. So I wrote an Emacs Lisp function to gave me the matching groups:

(defun my-match-groups (&optional object)
  "Return the matching groups, good for debugging regexps."
  (seq-map-indexed (lambda (entry i)
                     (list i entry
                           (and (car entry)
                                (if object
                                    (substring object (car entry) (cadr entry))
                                  (buffer-substring (car entry) (cadr entry))))))
                   (seq-partition
                    (match-data t)
                    2)))

There's probably a standard way to do this, but I couldn't figure out how to find it.

Anyway, if I give it a string with a bracketed link, I can tell that the URL ends up in group 2:

(let ((text "blah [[https://example.com][example]] blah blah"))
  (when (string-match org-link-any-re text)
    (pp-to-string (my-match-groups text))))
((0 (5 37) "[[https://example.com][example]]")
 (1 (5 37) "[[https://example.com][example]]")
 (2 (7 26) "https://example.com")
 (3 (28 35) "example"))

When I use a string with a bare link, I can see that the URL ends up in group 7:

(let ((text "blah https://example.com blah blah"))
  (when (string-match org-link-any-re text)
    (pp-to-string (my-match-groups text))))
((0 (5 24) "https://example.com")
 (1 (nil nil) nil) (2 (nil nil) nil)
 (3 (nil nil) nil) (4 (nil nil) nil)
 (5 (nil nil) nil) (6 (nil nil) nil)
 (7 (5 24) "https://example.com")
 (8 (5 10) "https") (9 (11 24) "//example.com"))

This makes it so much easier to refer to the right capture group. So now I can use those groups to extract the URL from a string:

(defun my-org-link-url-from-string (s)
  "Return the link URL from S."
  (when (string-match org-link-any-re s)
    (or
     (match-string 7 s)
       (match-string 2 s))))

This is handy when I summarize Emacs News links from Mastodon or from my inbox. Sometimes I add extra text after a link that I've captured from my phone, and I don't want that included in the URL. Sometimes I have a bracketed link that I've copied from org-capture note. Now I don't have to worry about the format. I can just grab the link I want.

View org source for this post

Updating YouTube videos via the YouTube Data API using Emacs Lisp and url-http-oauth

| elisp, emacs, emacsconf, youtube, video

We upload EmacsConf videos to both YouTube and Toobnix, which is a PeerTube instance. This makes it easier for people to come across them after the conference.

I can upload to Toobnix and set titles and descriptions using the peertube-cli tool. I tried a Python script for uploading to YouTube, but it was a bit annoying due to quota restrictions. Instead, I uploaded the videos by dragging and dropping them into YouTube Studio. This allowed me to upload 15 at a time.

The videos on YouTube had just the filenames. I wanted to rename the videos and set the descriptions. In 2022, I used xdotool, simulating mouse clicks and pasting in text for larger text blocks.

Xdotool script
(defun my-xdotool-insert-mouse-location
    (interactive)
  (let ((pos (shell-command-to-string "xdotool getmouselocation")))
    (when (string-match "x:\\([0-9]+\\) y:\\([0-9]+\\)" pos)
      (insert (format "(shell-command \"xdotool mousemove %s %s click 1\")\n" (match-string 1 pos) (match-string 2 pos))))))

(setq list (seq-filter (lambda (o)
                         (and
                          (file-exists-p
                           (expand-file-name
                            (concat (plist-get o :video-slug) "--final.webm")
                            emacsconf-cache-dir))
                          (null (plist-get o :youtube-url))))
            (emacsconf-publish-prepare-for-display (emacsconf-get-talk-info))))

(while list
  (progn
    (shell-command "xdotool mousemove 707 812 click 1 sleep 2")

    (setq talk (pop list))
    ;; click create
    (shell-command "xdotool mousemove 843 187 click 1 sleep 1")
    ;; video
    (shell-command "xdotool mousemove 833 217 click 1 sleep 1")
    ;; select files
    (shell-command (concat "xdotool mousemove 491 760 click 1 sleep 4 type "
                           (shell-quote-argument (concat (plist-get talk :video-slug) "--final.webm"))))
    ;; open
    (shell-command "xdotool mousemove 1318 847 click 1 sleep 5")

    (kill-new (concat
               emacsconf-name " "
               emacsconf-year ": "
               (plist-get talk :title)
               " - "
               (plist-get talk :speakers-with-pronouns)))
    (shell-command "xdotool sleep 1 mousemove 331 440 click :1 key Ctrl+a Delete sleep 1 key Ctrl+Shift+v sleep 2")

    (kill-new (emacsconf-publish-video-description talk t))
    (shell-command "xdotool mousemove 474 632 click 1 sleep 1 key Ctrl+a sleep 1 key Delete sleep 1 key Ctrl+Shift+v"))
  (read-string "Press a key once you've pasted in the description")

  ;; next
  (when (emacsconf-captions-edited-p (expand-file-name (concat (plist-get talk :video-slug) "--main.vtt") emacsconf-cache-dir))
    (shell-command "xdotool mousemove 352 285 click 1 sleep 1")

    ;; add captions
    (shell-command "xdotool mousemove 877 474 click 1 sleep 3")
    (shell-command "xdotool mousemove 165 408 click 1 sleep 1")
    (shell-command "xdotool mousemove 633 740 click 1 sleep 2")
    (shell-command (concat "xdotool mousemove 914 755  click 1 sleep 4 type "
                           (shell-quote-argument (concat (plist-get talk :video-slug) "--main.vtt"))))
    (read-string "Press a key once you've loaded the VTT")
    (shell-command "xdotool mousemove 910 1037 sleep 1 click 1 sleep 4")
    ;; done
    (shell-command "xdotool mousemove 890 297 click 1 sleep 3")
    )


  (progn
    ;; visibility
    (shell-command "xdotool mousemove 810 303 click 1 sleep 2")
    ;; public
    (shell-command "xdotool mousemove 119 614 click 1 sleep 2")
    ;; copy
    (shell-command "xdotool mousemove 882 669 click 1 sleep 1")
    ;; done
    (shell-command "xdotool mousemove 908 1089 click 1 sleep 5 key Alt+Tab")

    (emacsconf-with-talk-heading talk
      (org-entry-put (point) "YOUTUBE_URL" (read-string "URL: "))
      ))
  )

Using xdotool wasn't very elegant, since I needed to figure out the coordinates for each click. I tried using Spookfox to control Mozilla Firefox from Emacs, but Youtube's editing interface didn't seem to have any textboxes that I could set. I decided to use EmacsConf 2023 as an excuse to learn how to talk to the Youtube Data API, which required figuring out OAuth. Even though it was easy to find examples in Python and NodeJS, I wanted to see if I could stick with using Emacs Lisp so that I could add the code to the emacsconf-el repository.

After a quick search, I picked url-http-oauth as the library that I'd try first. I used the url-http-oauth-demo.el included in the package to figure out what to set for the YouTube Data API. I wrote a function to make getting the redirect URL easier (emacsconf-extract-oauth-browse-and-prompt). Once I authenticated successfully, I explored using alphapapa's plz library. It can handle finding the JSON object and parsing it out for me. With it, I updated videos to include titles and descriptions from my Emacs code, and I copied the video IDs into my Org properties.

emacsconf-extract.el code for Youtube renaming

;;; YouTube

;; When the token needs refreshing, delete the associated lines from
;; ~/.authinfo This code just sets the title and description. Still
;; need to figure out how to properly set the license, visibility,
;; recording date, and captions.
;;
;; To avoid being prompted for the client secret, it's helpful to have a line in ~/.authinfo or ~/.authinfo.gpg with
;; machine https://oauth2.googleapis.com/token username CLIENT_ID password CLIENT_SECRET

(defvar emacsconf-extract-google-client-identifier nil)
(defvar emacsconf-extract-youtube-api-channels nil)
(defvar emacsconf-extract-youtube-api-categories nil)

(defun emacsconf-extract-oauth-browse-and-prompt (url)
  "Open URL and wait for the redirected code URL."
  (browse-url url)
  (read-from-minibuffer "Paste the redirected code URL: "))

(defun emacsconf-extract-youtube-api-setup ()
  (interactive)
  (require 'plz)
  (require 'url-http-oauth)
  (when (getenv "GOOGLE_APPLICATION_CREDENTIALS")
    (let-alist (json-read-file (getenv "GOOGLE_APPLICATION_CREDENTIALS"))
      (setq emacsconf-extract-google-client-identifier .web.client_id)))
  (unless (url-http-oauth-interposed-p "https://youtube.googleapis.com/youtube/v3/")
    (url-http-oauth-interpose
     `(("client-identifier" . ,emacsconf-extract-google-client-identifier)
       ("resource-url" . "https://youtube.googleapis.com/youtube/v3/")
       ("authorization-code-function" . emacsconf-extract-oauth-browse-and-prompt)
       ("authorization-endpoint" . "https://accounts.google.com/o/oauth2/v2/auth")
       ("authorization-extra-arguments" .
        (("redirect_uri" . "http://localhost:8080")))
       ("access-token-endpoint" . "https://oauth2.googleapis.com/token")
       ("scope" . "https://www.googleapis.com/auth/youtube")
       ("client-secret-method" . prompt))))
  (setq emacsconf-extract-youtube-api-channels
        (plz 'get "https://youtube.googleapis.com/youtube/v3/channels?part=contentDetails&mine=true"
          :headers `(("Authorization" . ,(url-oauth-auth "https://youtube.googleapis.com/youtube/v3/")))
          :as #'json-read))
  (setq emacsconf-extract-youtube-api-categories
        (plz 'get "https://youtube.googleapis.com/youtube/v3/videoCategories?part=snippet&regionCode=CA"
          :headers `(("Authorization" . ,(url-oauth-auth "https://youtube.googleapis.com/youtube/v3/")))
          :as #'json-read))
  (setq emacsconf-extract-youtube-api-videos
        (plz 'get (concat "https://youtube.googleapis.com/youtube/v3/playlistItems?part=snippet,contentDetails,status&forMine=true&order=date&maxResults=50&playlistId="
                          (url-hexify-string
                           (let-alist (elt (assoc-default 'items emacsconf-extract-youtube-api-channels) 0)
                             .contentDetails.relatedPlaylists.uploads)
                           ))
          :headers `(("Authorization" . ,(url-oauth-auth "https://youtube.googleapis.com/youtube/v3/")))
          :as #'json-read)))

(defvar emacsconf-extract-youtube-tags '("emacs" "emacsconf"))
(defun emacsconf-extract-youtube-object (video-id talk &optional privacy-status)
  "Format the video object for VIDEO-ID using TALK details."
  (setq privacy-status (or privacy-status "unlisted"))
  (let ((properties (emacsconf-publish-talk-video-properties talk 'youtube)))
    `((id . ,video-id)
      (kind . "youtube#video")
      (snippet
       (categoryId . "28")
       (title . ,(plist-get properties :title))
       (tags . ,emacsconf-extract-youtube-tags)
       (description . ,(plist-get properties :description))
       ;; Even though I set recordingDetails and status, it doesn't seem to stick.
       ;; I'll leave this in here in case someone else can figure it out.
       (recordingDetails (recordingDate . ,(format-time-string "%Y-%m-%dT%TZ" (plist-get talk :start-time) t))))
      (status (privacyStatus . "unlisted")
              (license . "creativeCommon")))))

(defun emacsconf-extract-youtube-api-update-video (video-object)
  "Update VIDEO-OBJECT."
  (let-alist video-object
    (let* ((slug (cond
                  ;; not yet renamed
                  ((string-match (rx (literal emacsconf-id) " " (literal emacsconf-year) " "
                                     (group (1+ (or (syntax word) "-")))
                                     "  ")
                                 .snippet.title)
                   (match-string 1 .snippet.title))
                  ;; renamed, match the description instead
                  ((string-match (rx (literal emacsconf-base-url) (literal emacsconf-year) "/talks/"
                                     (group (1+ (or (syntax word) "-"))))
                                 .snippet.description)
                   (match-string 1 .snippet.description))
                  ;; can't find, prompt
                  (t
                   (when (string-match (rx (literal emacsconf-id) " " (literal emacsconf-year))
                                       .snippet.title)
                     (completing-read (format "Slug for %s: "
                                              .snippet.title)
                                      (seq-map (lambda (o) (plist-get o :slug))
                                               (emacsconf-publish-prepare-for-display (emacsconf-get-talk-info))))))))
           (video-id .snippet.resourceId.videoId)
           (id .id)
           result)
      (when slug
        ;; set the YOUTUBE_URL property
        (emacsconf-with-talk-heading slug
          (org-entry-put (point) "YOUTUBE_URL" (concat "https://www.youtube.com/watch?v=" video-id))
          (org-entry-put (point) "YOUTUBE_ID" id))
        (plz 'put "https://www.googleapis.com/youtube/v3/videos?part=snippet,recordingDetails,status"
          :headers `(("Authorization" . ,(url-oauth-auth "https://youtube.googleapis.com/youtube/v3/"))
                     ("Accept" . "application/json")
                     ("Content-Type" . "application/json"))
          :body (json-encode (emacsconf-extract-youtube-object video-id (emacsconf-resolve-talk slug))))))))

(defun emacsconf-extract-youtube-rename-videos (&optional videos)
  "Rename videos and set the YOUTUBE_URL property in the Org heading."
  (let ((info (emacsconf-get-talk-info)))
    (mapc
     (lambda (video)
       (when (string-match (rx (literal emacsconf-id) " " (literal emacsconf-year)))
         (emacsconf-extract-youtube-api-update-video video)))
     (assoc-default 'items (or videos emacsconf-extract-youtube-api-videos)))))

(provide 'emacsconf-extract)

I haven't quite figured out how to set status and recordingDetails properly. The code sets them, but they don't stick. That's okay. I think I can set those as a batch operation. It looks like I need to change visibility one by one, though, which might be a good opportunity to check the end of the video for anything that needs to be trimmed off.

I also want to figure out how to upload captions. I'm not entirely sure how to do multipart form data yet with the url library or plz. It might be nice to someday set up an HTTP server so that Emacs can handle OAuth redirects itself. I'll save that for another blog post and share my notes for now.

This code is in emacsconf-extract.el.

Checking image sizes and aspect ratios in Emacs Lisp so that I can automatically smartcrop them

| elisp, emacs

A+ occasionally likes to flip through pictures in a photo album. I want to print another batch of 4x6 photos, and I'd like to crop them before labeling them with the date from the EXIF info. Most of the pictures are from my phone, so I have a 4:3 aspect ratio instead of the 3:2 aspect ratio I want for prints.

First step: figuring out how to get the size of an image. I could either use Emacs's built-in image-size function or call ImageMagick's identify command. Which one's faster? First, I define the functions:

(defun my-image-size (filename)
  (let ((img (create-image filename)))
    (prog1 (image-size img t) (image-flush img))))

(defun my-identify-image-size (filename)
  (let ((result
         (seq-map 'string-to-number
                  (split-string
                   (shell-command-to-string
                    (concat "identify -format \"%w %h\" " (shell-quote-argument filename)))))))
    (when (and result (> (car result) 0))
      result)))

and then benchmark them:

(let ((filename "~/Downloads/Other prints/20230102_135059.MP.jpg")
      (times 10))
  (list (benchmark times `(my-image-size ,filename))
        (benchmark times `(my-identify-image-size ,filename))))

Looks like ImageMagick's identify command is a lot faster. Now I can define a filter:

Code for aspect ratios
(defun my-aspect-ratio (normalize &rest args)
  "Return the aspect ratio of ARGS.
If NORMALIZE is non-nil, return an aspect ratio >= 1 (width is greater than height).
ARGS can be:
- width height
- a filename
- a list of (width height)"
  (let (size width height result)
    (cond
     ((stringp (car args))
      (setq size (my-identify-image-size (car args)))
      (setq width (car size) height (cadr size)))
     ((listp (car args))
      (setq width (car (car args)) height (cadr (car args))))
     (t
      (setq width (car args) height (cadr args))))
    (when (and width height)
      (setq result (/ (* 1.0 width) height))
      (if (and normalize (< result 1))
          (/ 1 result)
        result))))

(defun my-files-not-matching-aspect-ratio (print-width print-height file-list)
  (let ((target-aspect-ratio (my-aspect-ratio t print-width print-height)))
    (seq-filter
     (lambda (filename)
       (let ((image-ratio (my-aspect-ratio t filename)))
         (when image-ratio
           (> (abs (- image-ratio
                      target-aspect-ratio))
              0.001))))
     file-list)))

and I could use it like this to get a list of files that need to be cropped:

(my-files-not-matching-aspect-ratio 4 6 (directory-files "~/Downloads/Other prints" t))

… which is most of the pictures, so let's see if I can get smartcrop to automatically crop them as a starting point. I used npm install -g smartcrop-cli node-opencv to install the Node packages I needed, and then I defined these functions:

Code for cropping
(defvar my-smartcrop-image-command '("smartcrop" "--faceDetection"))

(defun my-smartcrop-image (filename aspect-ratio output-file &optional do-copy)
  "Call smartcrop command to crop FILENAME to ASPECT-RATIO if needed.
Write the result to OUTPUT-FILE.
If DO-COPY is non-nil, copy files if they already have the correct aspect ratio."
  (when (file-directory-p output-file)
    (setq output-file (expand-file-name (file-name-nondirectory filename)
                                        output-file)))
  (let* ((size (my-identify-image-size filename))
         (image-ratio (my-aspect-ratio t size))
         new-height new-width
         buf)
    (when image-ratio
      (if (< (abs (- image-ratio aspect-ratio)) 0.01)
          (when do-copy (copy-file filename output-file t))
        (with-current-buffer (get-buffer-create "*smartcrop*")
          (erase-buffer)
          (setq new-width
                (number-to-string
                 (floor (min
                         (car size)
                         (*
                          (cadr size)
                          (if (> (car size) (cadr size))
                              aspect-ratio
                            (/ 1.0 aspect-ratio))))))
                new-height
                (number-to-string
                 (floor (min
                         (cadr size)
                         (/
                          (car size)
                          (if (> (car size) (cadr size))
                              aspect-ratio
                            (/ 1.0 aspect-ratio)))))))
          (message "%d %d -> %s %s: %s" (car size) (cadr size) new-width new-height filename)
          (apply 'call-process
           (car
            my-smartcrop-image-command)
           nil t t
           (append
            (cdr my-smartcrop-image-command)
            (list
             "--width"
             new-width
             "--height"
             new-height
             filename
             output-file))))))))

so that I could use this code to process the files:

(let ((aspect-ratio (my-aspect-ratio t 4 6))
      (output-dir "~/Downloads/Other prints/cropped"))
  (mapc (lambda (file)
          (unless (file-exists-p (expand-file-name (file-name-nondirectory file) output-dir))
            (my-smartcrop-image file  aspect-ratio output-dir t)))
        (directory-files "~/Downloads/Other prints" t)))

Then I can use Geeqie to review the cropped images and straighten or re-crop specific ones with Shotwell.

It looks like smartcrop removes the exif information (including original date), so I want to copy that info again.

for FILE in *; do exiftool -TagsFromFile "../$FILE" "-all:all>all:all" "exif/$FILE"; done

And then finally, I can add the labels with this add-labels.py script, which I call with add-labels.py output-dir file1 file2 file3....

add-labels.py: add the date to the lower left corner
#!/usr/bin/python3
import sys
import PIL
import PIL.Image as Image
import PIL.ImageDraw as ImageDraw
import PIL.ImageFont as ImageFont
from PIL import Image, ExifTags
import re
import os

# use: add-labels.py output-dir photo1 photo2 photo3
PHOTO_DIR = "/home/sacha/photos/"
OUTPUT_DIR = sys.argv[1]
OUTPUT_WIDTH = 6
OUTPUT_HEIGHT = 4
OUTPUT_RATIO = OUTPUT_WIDTH * 1.0 / OUTPUT_HEIGHT
font_fname = "/usr/share/fonts/truetype/noto/NotoSans-Regular.ttf"
ALWAYS = True
DO_ROTATE = False

def label_image(filename):
    numbers = re.sub(r'[^0-9]', '', filename)
    img = Image.open(filename)
    exif = {
        PIL.ExifTags.TAGS[k]: v
        for k, v in img._getexif().items()        if k in PIL.ExifTags.TAGS
    }
    if DO_ROTATE:
        # Rotate image
        if exif['Orientation'] == 3:
            img = img.rotate(180, expand=True)
        elif exif['Orientation'] == 6:
            img = img.rotate(270, expand=True)
        elif exif['Orientation'] == 8:
            img = img.rotate(90, expand=True)    
    # Label
    time = exif['DateTimeOriginal'][0:10].replace(':', '-')
    if not time:
        if len(numbers) >= 10 and numbers[0:4] >= '2016' and numbers[0:4] < '2025':
            time = '%s-%s-%s' % (numbers[0:4], numbers[4:6], numbers[6:8])
    new_filename = os.path.join(OUTPUT_DIR, time + ' ' + os.path.basename(filename))
    if ALWAYS or not os.path.isfile(new_filename):
        out = add_label(img, time)
        print(filename, time)
        out.save(new_filename)
        return new_filename

def add_label(img, caption):
    draw = ImageDraw.Draw(img)
    w, h = img.size
    border = int(min(w, h) * 0.02)
    font_size = int(min(w, h) * 0.04)
    # print(w, h, font_size)
    font = ImageFont.truetype(font_fname, font_size)
    _, _, text_w, text_h = draw.textbbox((0, 0), caption, font)
    overlay = Image.new('RGBA', (w, h))
    draw = ImageDraw.Draw(overlay)
    draw.rectangle([(border, h - text_h - 2 * border),
                    (text_w + 3 * border, h - border)],
                   fill=(255, 255, 255, 128))
    draw.text((border * 2, h - text_h - 2 * border), caption, (0, 0, 0), font=font)
    out = Image.alpha_composite(img.convert('RGBA'), overlay).convert('RGB')
    return out

if len(sys.argv) >= 2:
    for a in sys.argv[2:]:
        if ALWAYS or not os.path.exists(a):
            print(a)
            try:
                label_image(a)
            except Exception as e:
                print("Error", a, e)

I hope it all works out, since I've just ordered 120 4x6 prints covering the past three years or so…

Making highlight-sexp follow modus-themes-toggle

| elisp, emacs

[2023-01-27 Fri] Prot just added a modus-themes-get-color-value function. Yay! Also, it turns out that I need to update the overlay in all the buffers.

I'm experimenting with using the highlight-sexp minor mode to highlight my current s-expression, since I sometimes get confused about what I'm modifying with smartparens. The highlight-sexp background colour is hardcoded in the variable hl-sexp-background-color, and will probably look terrible if you use a light background. I wanted it to adapt when I use modus-themes-toggle. Here's how that works:

(use-package highlight-sexp
  :quelpa
  (highlight-sexp :repo "daimrod/highlight-sexp" :fetcher github :version original)
  :hook
  (emacs-lisp-mode . highlight-sexp-mode)
  :config
  (defun my-hl-sexp-update-overlay ()
    (when (overlayp hl-sexp-overlay)
      (overlay-put
       hl-sexp-overlay
       'face
       `(:background        
         ,(if (fboundp 'modus-themes-get-color-value)
              (modus-themes-get-color-value 'bg-inactive)
            (car
             (assoc-default
              'bg-inactive
              (modus-themes--current-theme-palette))))))))
  (defun my-hl-sexp-update-all-overlays ()
    (dolist (buf (buffer-list))
      (with-current-buffer buf
        (when highlight-sexp-mode
          (my-hl-sexp-update-overlay)))))
  (advice-add 'hl-sexp-create-overlay :after 'my-hl-sexp-update-overlay)
  (advice-add 'modus-themes-toggle :after 'my-hl-sexp-update-all-overlays))

This is what it looks like:

highlight-sexp.gif
Figure 1: Animation of highlight-sexp toggling along with modus-themes-toggle
This is part of my Emacs configuration.

Display a calendar heat map using Emacs Lisp

| elisp, emacs

I was curious about how to quickly visualize my date-related data in Emacs, such as when I sketched my thoughts or which days had journal entries or how often A- had tantrums. (It's hard to be 6 years old.) I wrote this code based on nrougier's code for colouring calendar days using advice around calendar-generate-entries:

(defface calendar-scale-1  '((((background light)) :foreground "black" :background "#eceff1")
                             (((background dark))  :foreground "white" :background "#263238")) "")
(defface calendar-scale-2  '((((background light)) :foreground "black" :background "#cfd8dc")
                             (((background dark))  :foreground "white" :background "#37474f")) "")
(defface calendar-scale-3  '((((background light)) :foreground "black" :background "#b0bec5")
                             (((background dark))  :foreground "white" :background "#455a64")) "")
(defface calendar-scale-4  '((((background light)) :foreground "black" :background "#90a4ae")
                             (((background dark))  :foreground "white" :background "#546e7a")) "")
(defface calendar-scale-5  '((((background light)) :foreground "black" :background "#78909c")
                             (((background dark))  :foreground "white" :background "#607d8b")) "")
(defface calendar-scale-6  '((((background light)) :foreground "black" :background "#607d8b")
                             (((background dark))  :foreground "white" :background "#78909c")) "")
(defface calendar-scale-7  '((((background light)) :foreground "black" :background "#546e7a")
                             (((background dark))  :foreground "white" :background "#90a4ae")) "")
(defface calendar-scale-8  '((((background light)) :foreground "black" :background "#455a64")
                             (((background dark))  :foreground "white" :background "#b0bec5")) "")
(defface calendar-scale-9  '((((background light)) :foreground "black" :background "#37474f")
                             (((background dark))  :foreground "white" :background "#cfd8dc")) "")
(defface calendar-scale-10 '((((background light)) :foreground "black" :background "#263238")
                             (((background dark))  :foreground "white" :background "#eceff1")) "")

(defun my-count-calendar-entries (grouped-entries)
  (mapcar (lambda (entry) (cons (car entry) (length (cdr entry)))) grouped-entries))

(defun my-scale-calendar-entries (grouped-entries &optional scale-max)
  (let* ((count (my-count-calendar-entries grouped-entries))
         (count-max (apply #'max (mapcar (lambda (o) (if (car o) (cdr o) 0)) count))))
    (mapcar (lambda (entry)
              (cons (car entry)
                    (/ (* 1.0 (or scale-max 1.0) (cdr entry)) count-max)))
            count)))

(defun my-scale-calendar-entries-logarithmically (grouped-entries &optional scale-max)
  (let* ((count (my-count-calendar-entries grouped-entries))
         (count-max (apply #'max (mapcar (lambda (o) (if (car o) (cdr o) 0)) count))))
    (mapcar (lambda (entry)
              (cons (car entry)
                    (/ (* 1.0 (or scale-max 1.0) (log (cdr entry))) (log count-max))))
            count)))

(defvar my-calendar-count-scaled nil "Values to display.")

(defun my-calendar-heat-map (month year indent)
  (when my-calendar-count-scaled
    (dotimes (i 31)
      (let ((date (list month (1+ i) year))
            (count-scaled (assoc-default (format "%04d-%02d-%02d" year month (1+ i))
                                         my-calendar-count-scaled)))
        (when count-scaled
          (calendar-mark-visible-date
           date
           (intern (format "calendar-scale-%d" count-scaled))))))))

(advice-add #'calendar-generate-month :after #'my-calendar-heat-map)
;(advice-remove #'calendar-generate-month #'my-calendar-heat-map)

(defun my-calendar-visualize (values)
  (setq my-calendar-count-scaled values)
  (calendar))

Journal entries

So if I want to visualize the days with journal entries, I can use this code:

(defun my-calendar-visualize-journal-entries ()
  (interactive)
  (my-calendar-visualize
   (mapcar
    (lambda (o)
      (cons
       (car o)
       (ceiling (+ 1 (* 7.0 (cdr o))))))
    (my-scale-calendar-entries
     (seq-group-by #'my-journal-date
                   (cdr (pcsv-parse-file "~/Downloads/entries.csv")))))))
2023-01-05_21-42-06.png
Figure 1: Journal entries

Sketches

(defun my-calendar-visualize-sketches ()
  (interactive)
  (let ((my-calendar-sketches
         (assoc-delete-all
          nil
          (seq-group-by
           (lambda (o)
             (when (string-match "^\\([0-9][0-9][0-9][0-9]\\)[-_]?\\([0-9][0-9]\\)[-_]?\\([0-9][0-9]\\)" o)
               (format "%s-%s-%s"
                       (match-string 1 o)
                       (match-string 2 o)
                       (match-string 3 o))))
           (append
            (directory-files "~/sync/sketches" nil "\\.\\(png\\|jpg\\)\\'")
            (directory-files "~/sync/private-sketches" nil "\\.\\(png\\|jpg\\)\\'"))))))
    (my-calendar-visualize
     (mapcar
      (lambda (o)
        (cons (car o)
              ;; many days have just 1 sketch, so I set the low end of the scale
              ;; to make them visible, and use a logarithmic scale for the rest
              (ceiling (+ 3 (* 7.0 (cdr o))))))
      (my-scale-calendar-entries-logarithmically my-calendar-sketches)))))
2023-01-05_21-37-03.png
Figure 2: Sketches

Big feelings

(defun my-calendar-visualize-tantrums ()
  (interactive)
  (my-calendar-visualize
   (mapcar
    (lambda (o)
      (cons
       (car o)
       (ceiling (* 10.0 (cdr o)))))
    (my-scale-calendar-entries
     (seq-group-by #'my-journal-date
                   (seq-filter (lambda (o) (string-match "tantrum\\|grump\\|angry\\|meltdown"
                                                           (my-journal-note o)))
                               (cdr (pcsv-parse-file "~/Downloads/entries.csv"))))))))
2023-01-05_21-46-22.png
Figure 3: Tantrums and meltdowns

(The start of the schoolyear was pretty rough.)

I'd like to figure out a yearly calendar view, and maybe use the calendar as a way to navigate my data too. calendar-mark-visible-date relies on the position and gets confused by the stuff I tried from these yearly calendar hacks, but maybe I can change calendar-date-echo-text to '(calendar-iso-date-string (list month day year)) and then extract the data from the help-echo property, since mysteriously, the date doesn't actually seem to be otherwise stored in the calendar. Anyway, I'll post that when I figure it out!

Coverage reporting in Emacs with Buttercup, Undercover, Coverage, and a Makefile

| emacs, elisp, subed

One of the things that I always wanted to get back to was the practice of having good test coverage. That way, I can have all these tests catch me in case I break something in my sleep-deprived late-night hacking sessions, and I can see where I may have missed a spot.

Fortunately, subed-mode included lots of tests using the Buttercup testing framework. They look like this:

(describe "SRT"
  (describe "Getting"
    (describe "the subtitle ID"
      (it "returns the subtitle ID if it can be found."
        (with-temp-srt-buffer
         (insert mock-srt-data)
         (subed-jump-to-subtitle-text 2)
         (expect (subed-subtitle-id) :to-equal 2)))
      (it "returns nil if no subtitle ID can be found."
        (with-temp-srt-buffer
         (expect (subed-subtitle-id) :to-equal nil))))
    ...))

and I can run them with make test, which the Makefile defines as emacs -batch -f package-initialize -L . -f buttercup-run-discover.

I don't have Cask set up for subed. I should probably learn how to use Cask. In the meantime, I needed to figure out how to get my Makefile to get the buttercup tests to capture the coverage data and report it in a nice way.

It turns out that the undercover coverage recording library works well with buttercup. It took me a little fiddling (and some reference to undercover.el-buttercup-integration-example) to figure out exactly how to invoke it so that undercover instrumented libraries that I was loading, since the subed files were in one subdirectory and the tests were in another. This is what I eventually came up with for tests/undercover-init.el:

(add-to-list 'load-path "./subed")
(when (require 'undercover nil t)
  (undercover "./subed/*.el" (:report-format 'simplecov) (:send-report nil)))

Then the tests files could start with:

(load-file "./tests/undercover-init.el")
(require 'subed-srt)

and my Makefile target for running tests with coverage reporting could be:

test-coverage:
	mkdir -p coverage
	UNDERCOVER_FORCE=true emacs -batch -L . -f package-initialize -f buttercup-run-discover

Displaying the coverage information in code buffers was easy with the coverage package. It looks in the git root directory for the coverage results, so I didn't need to tell it where the results were. This is what it looks like:

2022-01-02-19-00-28.svg

There are a few other options for displaying coverage info. cov uses the fringe and coverlay focuses on highlighting missed lines.

So now I can actually see how things are going, and I can start writing tests for some of those gaps. At some point I may even do the badge thing mentioned in my blog post from 2015 on continuous integration and code coverage for Emacs packages. There are a lot of things I'm slowly remembering how to do… =)