Exemplify-Eval — Create arrowified examples from sexps (Emacs package)

(* 6 7)
(cons :a 1)
(string= 4 2)
(concat "a" foo "b")
(h<-alist '((:a . 1) (:b . 2)))
#s(hash-table data (:a 1))

(h<-alist '((:a . 1) (:b . 2) (:c . 3) (:d . 4) (:e . 5)))

(* 6 7) => 42
(cons :a 1) => '(:a . 1)
(string= 4 2) !!> wrong-type-argument
(concat "a" foo "b") !!> void-variable
(h<-alist '((:a . 1) (:b . 2))) H=> (h* :a 1 :b 2)
#s(hash-table data (:a 1)) H=> (h-st* 65 'eql :a 1)

(h<-alist '((:a . 1) (:b . 2) (:c . 3) (:d . 4) (:e . 5)))
H=> (h* :a 1
        :b 2
        :c 3
        :d 4
        :e 5)

(use-package exemplify-eval
  :bind ("C-x e" . exemplify-eval-do))  ; or any key you prefer

(require exemplify-eval)

;;; exemplify-eval.el --- Create arrowified examples from sexps -*- lexical-binding: t -*-
;;; Commentary:
;;;; For all the details, please do see the README
;;; Code:
;;;; Libraries
;;;; Symbols from other packages
;;;; Package metadata
;;;; Customizable variables
;;;; Other variables
;;;;; Regular expressions
;;;; Functions
;;;;; Arrowify or dearrowify
;;;;;; Core
;;;;;;; Dispatcher
;;;;;;; Arrowify
;;;;;;; Dearrowify
;;;;;; Helpers
;;;;;; Movement
;;;;;; Deletion
;;;;;; Predicates
;;;;; See README
;;;; Wrapping up
;;; exemplify-eval.el ends here

;;; exemplify-eval.el --- Create arrowified examples from sexps -*- lexical-binding: t -*-

;; SPDX-FileCopyrightText: © flandrew <https://flandrew.srht.site/listful>

;;---------------------------------------------------------------------------
;; Author:    flandrew
;; Created:   2024-09-29
;; Updated:   2025-01-02
;; Keywords:  convenience, lisp
;; Homepage:  <https://flandrew.srht.site/listful/software.html>
;;---------------------------------------------------------------------------
;; Package-Version:  0.1.1
;; Package-Requires: ((emacs "25.1") (xht "1.0.6"))
;;---------------------------------------------------------------------------

;; SPDX-License-Identifier: GPL-3.0-or-later

;; 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 of the License,
;; 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.
;;
;; You should have received a copy of the GNU General Public License
;; along with this file. If not, see <https://www.gnu.org/licenses/>.

;;; Commentary:
;;
;; Exemplify-Eval creates Exemplify-ERT–like evaluations.
;;
;; From this:
;;   (* 6 7)
;;   (cons :a 1)
;;   #s(hash-table data (:a 1))
;;   (h<-alist '((:a . 1) (:b . 2)))
;;   (h<-alist '((:a . 1) (:b . 2) (:c . 3) (:d . 4) (:e . 5)))
;;
;; To this:
;;   (* 6 7) => 42
;;   (cons :a 1) => '(:a . 1)
;;   (h<-alist '((:a . 1) (:b . 2))) H=> (h* :a 1 :b 2)
;;   (h<-alist '((:a . 1) (:b . 2) (:c . 3) (:d . 4) (:e . 5)))
;;   H=> (h* :a 1
;;           :b 2
;;           :c 3
;;           :d 4
;;           :e 5)
;;
;; These examples can double as ERT tests when used with Exemplify-ERT.
;;
;;;; For all the details, please do see the README
;;
;; Open it easily with:
;;   (find-file-read-only "README.org")   <--- C-x C-e here¹
;;
;; or from any buffer:
;;   M-x exemplify-eval-see-readme
;;
;; or read it online:
;;   <https://flandrew.srht.site/listful/sw-emacs-exemplify-eval.html>
;;
;; ¹ or the key that ‘eval-last-sexp’ is bound to, if not C-x C-e.
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;



;;; Code:
;;;; Libraries

(require 'pp)
(require 'xht)       ; <---also by the author of this package
(require 'lisp-mnt)  ; ‘lm-summary’, ‘lm-homepage’, ‘lm-version’, ‘lm-header’


;;;; Symbols from other packages

;; Silence "not known to be defined" compiler warnings
(declare-function exemplify-align-arrowheads "ext:exemplify-align" (&optional
                                                                    spacing))


;;;; Package metadata

(defvar exemplify-eval--name "Exemplify-Eval")

(defvar exemplify-eval--dot-el
  (format "%s.el" (file-name-sans-extension (eval-and-compile
                                              (or load-file-name
                                                  buffer-file-name)))))
(defvar exemplify-eval--readme-org
  (expand-file-name "README.org" (file-name-directory exemplify-eval--dot-el)))

(defvar exemplify-eval--summary  (lm-summary   exemplify-eval--dot-el))
(defvar exemplify-eval--homepage (lm-homepage  exemplify-eval--dot-el))
(defvar exemplify-eval--version  (lm-with-file exemplify-eval--dot-el
                                   (or (lm-header "package-version")
                                       (lm-version))))


;;;; Customizable variables

(defgroup exemplify-eval nil
  (format "%s." exemplify-eval--summary)
  :group 'convenience
  :link  '(emacs-library-link :tag "Lisp file" "exemplify-eval.el")
  :link  `(file-link :tag "README.org" ,exemplify-eval--readme-org)
  :link  `(url-link  :tag "Homepage"   ,exemplify-eval--homepage))


;;;; Other variables
;;;;; Regular expressions

(defvar exemplify-eval--space-rx "[\s\t\r\n]*")
(defvar exemplify-eval--arrow-rx "\\([[:alnum:]]*=+>\\|!!>\\|~>\\)")
(defvar exemplify-eval--space-arrow-rx (concat exemplify-eval--space-rx
                                               exemplify-eval--arrow-rx))
(defvar exemplify-eval--at-ert-sexp-rx (concat "[\s\t]*(" "exemplify-ert"
                                               exemplify-eval--space-rx))
(defvar exemplify-eval--at-comments-rx "[\s\t]*\\(;\\|#\\+\\|[\n\r]\\)"
  "Comments, boundaries of org src blocks, and empty lines.")


;;;; Functions

(defmacro exemplify-eval--describe (str)
  "Describe with string STR the contents under this heading.
Think of it as a docstring for the headings of your elisp files.

For the full docstring, look for ‘orgreadme-fy-describe’ in the
package ‘orgreadme-fy’."
  (declare (indent 0))
  (unless (stringp str)
    (user-error "‘exemplify-eval--describe’ must receive a string")))

;;;;; Arrowify or dearrowify

(exemplify-eval--describe
  "Commands to create or remove arrowified evaluations.

| Dispatcher | All creation and removal actions under a single command |
| Arrowify   | Create Exemplify-ERT–like evaluations                   |
| Dearrowify | Remove Exemplify-ERT–like evaluations                   |")

;;;;;; Core
;;;;;;; Dispatcher

(exemplify-eval--describe
  "All actions can be accessed from here using numeric prefix keys.")

;;;###autoload
(defun exemplify-eval-do (&optional arg)
  "Run an exemplify-eval command.
Numeric prefix ARG selects the command.

ARG defaults to 1, and can be:
- 1: Run ‘exemplify-eval-arrowify-sexp’.
- 2: Run ‘exemplify-eval-arrowify-region’.
- 3: Run ‘exemplify-eval-arrowify-region-and-align’.
- 5: Run ‘exemplify-eval-dearrowify-sexp’.
- 6: Run ‘exemplify-eval-dearrowify-region’.
- Otherwise: choose from menu."
  (interactive "p")
  (pcase arg
    (1 (exemplify-eval-arrowify-sexp))
    (2 (exemplify-eval-arrowify-region))
    (3 (exemplify-eval-arrowify-region-and-align))
    (5 (exemplify-eval-dearrowify-sexp))
    (6 (exemplify-eval-dearrowify-region))
    (_ (exemplify-eval-do (exemplify-eval--choose)))))


;;;;;;; Arrowify

(exemplify-eval--describe
  "Commands to create arrowified evaluations.")

;;;###autoload
(defun exemplify-eval-arrowify-sexp ()
  "Insert evaluation of sexp, preceded by an appropriate arrow.
If there were previous results, replace them.

If the sexp evals to:

- error, print ‘!!>’ followed by the error type;

- a hash table, use the symbol ‘H=>’ instead, followed by a (h*…)
  representation — or (h-st*…) when the test used isn't \\='equal;

- anything else, use ‘=>’ followed by the regular evaluation, which
  gets quoted if it's either a symbol or a non-lambda cons.

If the sexp spans:

- a single line, then put the arrow at the end of that line, and
  present compact results in a single line.

- multiple lines, then put the arrow at the start of the next line,
  and pretty-print results (which can thereby span several lines);

This command can be run from anywhere inside the sexp to be eval'd,
or from the end of the line where the sexp ends (even if that is
inside previous evaluation results)."
  (interactive)
  (barf-if-buffer-read-only)
  (save-excursion
    (let (1line?  ; is last sexp in a single line?
          break?  ; should we put the results in the next line?
          read    ; eval of last sexp (or error type as string)
          last    ; last sexp as string
          slen    ; length of ‘last’ (or of error string)
          type    ; ‘h-type’ of last sexp, or :error
          before  ; possible space before the arrow
          arrow   ; arrow as string
          after   ; possible space after the arrow, and maybe a [']
          arrstr) ; before + arrow + after
      ;; Delete arrow and results, if any
      (exemplify-eval--dearrowify-sexp-1)
      ;; Check what kind of thing the last sexp is
      (condition-case err
          (setq read (eval-last-sexp nil)
                last (format "%s" read)  ; str
                slen (length last)
                type (h-type read))
        (error (setq read (format "%s" (car err))
                     slen (length read)
                     type :err)))
      ;; Select arrow and decide whether to put results in next line
      (setq arrow  (pcase type (:err "!!>") (:ht "H=>") (_ "=>"))
            1line? (exemplify-eval--last-sexp-in-single-line-p)
            break? (if (not 1line?)
                       t
                     (pcase type
                       (:ht (setq slen (length (h-h*-cm-str read)))))
                     (let* ((alen (length arrow))
                            (olen (-> (point)
                                      (- (line-beginning-position))
                                      (+ 1 alen 2 slen))))
                       (> olen (window-width)))))
      ;; Insert sexp
      (save-excursion
        (pcase type
          (:err (insert read))
          (:ht  (insert (if break? (h-h*-pp-str read) (h-h*-cm-str read))))
          (_    (if (not break?)
                    (eval-last-sexp (if (eq (type-of read) 'integer)
                                        'insert  ; just the integer
                                      0))        ; do not truncate
                  (pp-eval-last-sexp 'insert)
                  (exemplify-eval--chomp)))))
      ;; Insert arrow string
      (setq before (if break?
                       "\n"
                     (and 1line?
                          (not (exemplify-eval--prev-str-p "\s"))
                          "\s"))
            after  (concat "\s"
                           (pcase type
                             (:err) (:ht) ;nil
                             (_ (when (exemplify-eval--quotable-p read)
                                  "'"))))
            arrstr (concat before arrow after))
      (insert arrstr))))

;;;###autoload
(defun exemplify-eval-arrowify-region ()
  "Run ‘exemplify-eval-arrowify-sexp’ on this region.
If no region is selected, act on the current paragraph.

Do it on every valid line. Some invalid lines that are skipped are
those that are commented, or empty, or representing ‘exemplify-ert’
sexps, or starting with an arrow."
  (interactive)
  (exemplify-eval--run-on-region #'exemplify-eval-arrowify-sexp))

;;;###autoload
(defun exemplify-eval-arrowify-region-and-align ()
  "Run ‘exemplify-eval-arrowify-region’, then align arrowheads.
To align arrowheads you need the package ‘exemplify-align’."
  (interactive)
  (exemplify-eval-arrowify-region)
  (if (require 'exemplify-align nil 'noerror)
      (exemplify-align-arrowheads 1)
    (error "To align arrowheads you need the package ‘exemplify-align’")))


;;;;;;; Dearrowify

(exemplify-eval--describe
  "Commands to remove arrowified evaluations.")

;;;###autoload
(defun exemplify-eval-dearrowify-sexp ()
  "Remove arrowified results and the whitespace before arrow.
Act on the sexp that ends on current line.

If arrowify results don't exist, do nothing."
  (interactive)
  (barf-if-buffer-read-only)
  (with-syntax-table emacs-lisp-mode-syntax-table
    (save-excursion
      (exemplify-eval--dearrowify-sexp-1)
      ;; This works fine in the absence of comments:
      ;;   (delete-trailing-whitespace (line-beginning-position)
      ;;                               (line-end-position))
      ;;
      ;; But when we have comments, we want to preserve the spacing before it.
      ;; With this, the relative position of a trailing comment is preserved
      ;; after alternately producing and removing evaluations.
      (let* ((nsp "[^\s\t]+")
             (pnt (point))
             (lbp (line-beginning-position))
             (beg (unless (looking-back nsp (1- pnt))
                    (save-match-data
                      (save-excursion
                        (1+ (re-search-backward nsp lbp t 1)))))))
        (when beg
          (delete-region beg pnt))))))

;;;###autoload
(defun exemplify-eval-dearrowify-region ()
  "Run ‘exemplify-eval-dearrowify-sexp’ on this region.
If no region is selected, act on the current paragraph.

Do it on every valid line. Some invalid lines that are skipped are
those that are commented, or empty, or representing ‘exemplify-ert’
sexps, or starting with an arrow."
  (interactive)
  (exemplify-eval--run-on-region #'exemplify-eval-dearrowify-sexp))


;;;;;; Helpers

(defun exemplify-eval--choose ()
  "Show options to choose from."
  (let* ((str '("1. Arrowify sexp"
                "2. Arrowify region"
                "3. Arrowify region and align"
                "5. Dearrowify sexp"
                "6. Dearrowify region"
                "> "))
         (str (s-join "\n" str))
         (chr '(?1 ?2 ?3 ?5 ?6)))
    (read (string (read-char-choice str chr)))))

(defun exemplify-eval--dearrowify-sexp-1 ()
  "Delete results and arrow, if they exist.
Act on the sexp that ends on this line.
Helper for ‘exemplify-eval-arrowify-sexp’ and
‘exemplify-eval-dearrowify-sexp’."
  ;; Find the arrow, if any
  (exemplify-eval--goto-sexp-arrow-maybe)
  ;; If before an arrow, delete arrow and results
  (when (looking-at exemplify-eval--space-arrow-rx)
    (exemplify-eval--delete-sexp 2)))

(defun exemplify-eval--run-on-region (fun)
  "Run FUN on this region or paragraph.
Helper for ‘exemplify-eval-arrowify-region’ and
‘exemplify-eval-dearrowify-region’."
  (let ((num 0) beg end lnb lne)
    (save-excursion
      (if mark-active
          (setq beg (min (point) (mark))
                end (max (point) (mark)))
        (backward-paragraph) (setq beg (1+ (point)))
        (forward-paragraph)  (setq end (1- (point))))
      (setq lnb (line-number-at-pos beg)
            lne (line-number-at-pos end))
      (goto-char (point-min))
      ;; Backwards, because result could span to next lines
      (forward-line (1- lne))
      (while (>= (line-number-at-pos) lnb)
        ;; Invalid lines such as comments and exemplify-ert sexps are skipped.
        ;; Arrows are also skipped, because they must come from previous
        ;; line's evaluation.
        (unless (or (looking-at exemplify-eval--at-comments-rx)
                    (looking-at exemplify-eval--at-ert-sexp-rx)
                    (looking-at exemplify-eval--space-arrow-rx))
          (funcall fun)
          (setq num (1+ num)))
        ;; Deal with bobp case: break loop after eval
        (if (> (line-number-at-pos) lnb)
            (forward-line -1)
          (setq lnb (1+ lnb)))))
    (message "%d sexp%s." num (if (= num 1) "" "s"))))


;;;;;; Movement

(defun exemplify-eval--goto-sexp-arrow-maybe ()
  "If there's an arrow after the sexp-to-be-eval'd, go there."
  (exemplify-eval--goto-after-sexp)
  (exemplify-eval--goto-arrow))

(defun exemplify-eval--goto-after-sexp ()
  "Go to the very end of the sexp we want to eval.
The sexp is the one that we're either inside, just before,
or anywhere in its last line."
  (goto-char (line-beginning-position))
  (let* ((inside (exemplify-eval--inside-exemplify-ert-p))
         (depth  (if inside 1 0)))
    (while (> (car (syntax-ppss)) depth)
      (up-list -1 t t))
    (forward-sexp)))

(defun exemplify-eval--goto-arrow ()
  "If arrow in this line, go to its beginning."
  (let (arrw)
    (save-excursion
      (save-match-data
        (goto-char (line-end-position))
        (when (re-search-backward exemplify-eval--arrow-rx
                                  (line-beginning-position) t 1)
          (forward-char)
          (backward-sexp)
          (setq arrw (point)))))
    (when arrw (goto-char arrw))))

(defun exemplify-eval--goto-top-of-list (&optional backward)
  "Move forward to the top level, out of all parentheses.
When prefix BACKWARD is non-nil, move backward."
  (condition-case nil
      (while t
        (up-list (if backward -1 1) t t))
    (error nil)))


;;;;;; Deletion

(defun exemplify-eval--delete-sexp (&optional n)
  "Delete N sexps forward.
If N is nil, delete 1. If N is negative, delete backward."
  (delete-region (point) (save-excursion
                           (forward-sexp (or n 1))
                           (point))))

(defun exemplify-eval--chomp ()
  "Delete one newline before point, if present."
  (exemplify-eval--prev-str-delete-maybe "\n"))

(defun exemplify-eval--prev-str-delete-maybe (str)
  "If STR precedes point, delete it."
  (when (exemplify-eval--prev-str-p str)
    (delete-char (- (length str)))))


;;;;;; Predicates

(defun exemplify-eval--quotable-p (obj)
  "Whether OBJ is a quotable symbol or looking at quotable list."
  (or (exemplify-eval--quotable-symbol-p obj)
      (exemplify-eval--looking-at-quotable-list-p)))

(defun exemplify-eval--quotable-symbol-p (obj)
  "Whether OBJ is a quotable symbol."
  (and (eq (type-of obj) 'symbol)
       (not (keywordp obj))
       (not (booleanp obj))))

(defun exemplify-eval--looking-at-quotable-list-p ()
  "Whether looking at a quotable list."
  (and (looking-at "(")
       (not (looking-at "(lambda"))))

(defun exemplify-eval--prev-str-p (str)
  "Return t if STR precedes point."
  (looking-back str (- (point) (length str))))

(defun exemplify-eval--last-sexp-in-single-line-p ()
  "Return t if the last sexp begins and ends in the same line."
  (= (line-number-at-pos) (save-excursion
                            (backward-sexp)
                            (line-number-at-pos))))

(defun exemplify-eval--inside-exemplify-ert-p ()
  "Whether we're inside an ‘exemplify-ert’ sexp."
  (save-excursion
    (exemplify-eval--goto-top-of-list 'backward)
    (looking-at exemplify-eval--at-ert-sexp-rx)))


;;;;; See README

(exemplify-eval--describe
  "Commands to open exemplify-eval's README.org.
Optionally, find things in it.")

;;;###autoload
(defun exemplify-eval-see-readme (&optional heading narrow)
  "Open exemplify-eval's README.org file.
Search for the file in exemplify-eval.el's directory.

If found, open it read-only.

If optional argument HEADING is passed, try to navigate to the
heading after opening it. HEADING should be a string.

If optional argument NARROW is non-nil, narrow to that heading.
This argument has no effect if HEADING is nil or not found."
  (interactive)
  (let ((readme exemplify-eval--readme-org))
    (if (file-exists-p readme)
        (let ((pr (make-progress-reporter
                   (format "Opening %s ... "
                           (abbreviate-file-name readme)))))
          (find-file-read-only readme)
          (when heading
            (exemplify-eval--goto-org-heading heading narrow))
          (progress-reporter-done pr))
      (message "Couldn't find %s's README.org" exemplify-eval--name))))

;;;###autoload
(defun exemplify-eval-see-news ()
  "See the News in exemplify-eval's README.org file."
  (interactive)
  (exemplify-eval-see-readme "News" 'narrow)
  (exemplify-eval--display-org-subtree))

(defun exemplify-eval--display-org-subtree ()
  "Selectively display org subtree."
  (let ((cmds '(outline-hide-subtree
                outline-show-children
                outline-next-heading
                outline-show-branches)))
    (and (fboundp (nth 0 cmds))
         (fboundp (nth 1 cmds))
         (fboundp (nth 2 cmds))
         (fboundp (nth 3 cmds))
         (mapc #'funcall cmds))))

(defun exemplify-eval--goto-org-heading (heading &optional narrow)
  "Navigate to org HEADING and optionally NARROW to it."
  (let* ((hrx (format "^[*]+ %s" heading))
         (pos (save-match-data
                (save-excursion
                  (save-restriction
                    (widen)
                    (goto-char (point-max))
                    (re-search-backward hrx nil t 1))))))
    (when pos
      (widen)
      (goto-char pos)
      (if (and narrow (fboundp 'org-narrow-to-subtree))
          (org-narrow-to-subtree)
        (recenter-top-bottom 1))
      (when (fboundp 'outline-show-subtree)
        (outline-show-subtree))
      (when (fboundp 'org-flag-drawer)
        (save-excursion
          (forward-line 1)
          (org-flag-drawer t))))))


;;;; Wrapping up

(provide 'exemplify-eval)

;; Local Variables:
;; coding:                     utf-8
;; indent-tabs-mode:           nil
;; sentence-end-double-space:  nil
;; outline-regexp:             ";;;;* "
;; End:

;;; exemplify-eval.el ends here