Exemplify-ERT: Clean examples that double as ERT declarations (Emacs package)

(use-package exemplify-ert
  :demand t
  :config
  (global-exemplify-ert-fontify-mode))

(require 'exemplify-ert)

;;; exemplify-ert.el --- Clean examples that double as ERT declarations -*- lexical-binding: t -*-
;;; Commentary:
;;;; For all the details, please do see the README
;;; Acknowledgments:
;;; Code:
;;;; Libraries
;;;; Obsolete symbols
;;;; Package metadata
;;;; Customizable variables
;;;; Other variables
;;;; Functions
;;;;; Equality-defining functions
;;;;; From examples to ERT
;;;;; Support
;;;; Commands
;;;;; Create examples/tests file
;;;;; Minor mode
;;;;; See README
;;;;; See News
;;;; Wrapping up
;;; exemplify-ert.el ends here

;;; exemplify-ert.el --- Clean examples that double as ERT declarations -*- lexical-binding: t -*-

;; SPDX-FileCopyrightText:  © flandrew <https://keyoxide.org/191F5B3E212EF1E515C19918AF32B9A5C1CCCB2D>
;; SPDX-License-Identifier: GPL-3.0-or-later

;;---------------------------------------------------------------------------
;; Author:            flandrew
;; Created:           2022-03-31
;; Version:           0.6.0
;; Homepage:          <https://flandrew.srht.site/listful/software.html>
;; Keywords:          maint, tools, lisp
;; Package-Requires:  ((emacs "25.1") (dash "2.14") (s "1.12") (f "0.20"))
;;---------------------------------------------------------------------------

;; This file is part of Exemplify-ERT, which is NOT part of GNU Emacs.

;; This program 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 program 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. For more details, see the full license at
;; either LICENSES/GPL-3.0-or-later.txt or <https://www.gnu.org/licenses/>.

;;; Commentary:
;;
;; Exemplify-ERT helps you write regression tests that double as clean-looking
;; examples. Features:
;;
;; - Write your tests as clean-looking equalities that don't have the noise of
;;   shoulds and should-nots — but still uses ERT in the background.
;;
;; - If should-equal and should-error aren't enough for you, use a list
;;   of pre-defined symbols that correspond to pre-defined equality functions.
;;
;; It's independent from, but goes hand-in-hand with, OrgReadme-fy, in case
;; you wish to export your tests/examples into a nicely-formatted README.org.
;;
;;;; For all the details, please do see the README
;;
;; Open it easily with any of the below:
;;   (find-file-read-only              "README.org")   <--- C-x C-e here¹, or
;;   (find-file-read-only-other-frame  "README.org")   <--- C-x C-e here¹, or
;;   (find-file-read-only-other-window "README.org")   <--- C-x C-e here¹
;;
;; or read it online:
;;   <https://flandrew.srht.site/listful/sw-emacs-exemplify-ert.html>
;;
;; ¹ or the key that ‘eval-last-sexp’ is bound to, if not C-x C-e.
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; Acknowledgments:
;;
;; The idea for this library came after seeing how clean Dash's ERT tests
;; looked in Dash's dev/examples.el. It uses code from there.
;;
;; After using the examples structure myself while writing XHT, I decided to
;; further develop the idea. The result was two independent packages that go
;; well together: Exemplify-ERT and OrgReadme-fy.
;;
;; A few of this library's functions have borrowed and changed code used in
;; Dash development, most notably the ‘exemplify-ert’ macro itself,
;; ‘exemplify-ert-approx=’, ‘exemplify-ert-example->test’, and the
;; ‘exemplify-ert-fontify-mode’.
;;
;; My thanks to Magnar Sveen and the other Dash contributors.
;;
;; About dash:
;;   SPDX-FileCopyrightText:  © 2012 Free Software Foundation, Inc.
;;   SPDX-License-Identifier: GPL-3.0-or-later
;;   Author:                  Magnar Sveen
;;   Homepage:                <https://github.com/magnars/dash.el>
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; Code:
;;;; Libraries

(require 'f)
(require 's)
(require 'rx)
(require 'ert)
(require 'dash)
(require 'lisp-mnt)  ; ‘lm-summary’, ‘lm-version’, ‘lm-homepage’

;;;; Obsolete symbols

(define-obsolete-function-alias 'approx= 'exemplify-ert-approx= "0.6")

;;;; Package metadata

(defconst exemplify-ert--name "Exemplify-ERT")

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

(defconst exemplify-ert--summary  (lm-summary  exemplify-ert--dot-el))
(defconst exemplify-ert--version  (lm-version  exemplify-ert--dot-el))
(defconst exemplify-ert--homepage (lm-homepage exemplify-ert--dot-el))

;;;; Customizable variables

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

(defcustom exemplify-ert-dev-subdir "dev"
  "Subdirectory that will have your examples file.
The examples file's name is defined by ‘exemplify-ert-examples-filename’."
  :type  'string
  :group 'exemplify-ert)

(defcustom exemplify-ert-examples-filename "examples.el"
  "Name of your examples file.
It will be stored under ‘exemplify-ert-dev-subdir’."
  :type  'string
  :group 'exemplify-ert)

;; See also, under Minor mode:
;; ‘exemplify-ert-fontlock-add-equality-operators’,
;; ‘exemplify-ert-fontlock-add-exemplify-ert-macros’,
;; ‘exemplify-ert-fontify-mode-lighter’.
;; ‘exemplify-ert-enable-fontlock’

;;;; Other variables

(defconst exemplify-ert-ops-default
  '((   => . equal    )   ; regular equality
    (Hp==> . h-pr==   )   ; equality for hash tables       ├> Available in
    ( Hp=> . h-pr=    )   ; equality for hash tables       │  package 'xht
    ( H==> . h==      )   ; equality for hash tables       │  by the same
    (  H=> . h=       )   ; equality for hash tables       │  author. They
    ( H_=> . h_=      )   ; equality for hash tables       │  allow you to
    ( H~=> . h~=      )   ; equality for hash tables       │  compare objs
    (  O=> . h-orgtbl=)   ; equality for org table strings │  with same kv
    (  A=> . h-alist= )   ; equality for association lists │  pairs.
    (  P=> . h-plist= )   ; equality for property lists    │
    (  L=> . h-lol=   )   ; equality for lists of lists    │
    (  T=> . h-tsv=   )   ; equality for TSVs              │
    (  C=> . h-csv=   )   ; equality for CSVs              │
    (  S=> . h-ssv=   )   ; equality for SSVs              │
    (  J=> . h-json=  )   ; equality for JSONs             │
    (  K=> . h-kvl=   )   ; equality for key–value lines   │
    (   ~> . exemplify-ert-approx=)) ; equality for floats
  "An alist of equality operators that can be used for your examples.

To use any of these starting with 'h-' you'll need to (require 'xht) in your
examples.el. They allow the comparison of hash tables, alists and others. You
don't need to use them, and they being on this list will cause no errors.

The most common one is ‘=>’, which will use ‘equal’ to compare both sides of
the equality. The ‘~>’ one allows small differences between floats. Use ‘!!>’
to signal error.

You may add new ones, or even override these, by customizing the variable
‘exemplify-ert-ops-user’.")

(defvar exemplify-ert-ops-user nil
  "An alist of user-added equality operators.

You may add new ones according to what you normally use. This list will be
checked before ‘exemplify-ert-ops-default’, so you may override the defaults if
you want (though I'd suggest to pick some different symbol instead).

To add your own operators, do it directly in the examples.el file. It should
look somewhat like this:

  (setq exemplify-ert-ops-user '(( str=> . string=   )
                             (char=> . char-equal)))

After which you can now add examples such as:

  (myfunc1 x y     str=>  \"xy\")
  (myfunc2 ?x ?y  char=>  ?x)

\(Although note that plain ‘equal’, which is behind the ‘=>’, could
accomplish the above already, so you probably don't need these two
new equalities.)")

(defvar exemplify-ert-epsilon 1e-15
  "Epsilon used in ‘exemplify-ert-approx=’.")

;;;; Functions
;;;;; Equality-defining functions

(defun exemplify-ert-approx= (u v)
  "Like ‘=’, but compares floats U and V within ‘exemplify-ert-epsilon’.
This allows approximate comparison of floats to work around
differences in implementation between systems. Used in place of
‘equal’ when testing actual and expected values with ‘~>’."
  (or (= u v)
      (< (/ (abs (- u v))
            (max (abs u) (abs v)))
         exemplify-ert-epsilon)))

;;;;; From examples to ERT

(defun exemplify-ert-example->test (example)
  "Return an ERT assertion form based on EXAMPLE."
  (pcase example
    (`(,actual !!> ,(and (pred symbolp) expected))
     ;; FIXME: Tests fail on Emacs 24-25 without ‘eval’ for some reason.
     `(should-error (eval ',actual ,lexical-binding)
                    :type ',expected))
    (`(,actual !!> ,expected)
     `(should (equal (should-error ,actual) ',expected)))
    (_
     (-let [(actual op expected) example]
       (let* ((alist (-concat exemplify-ert-ops-user
                              exemplify-ert-ops-default))
              (fun   (cdr (assoc op alist)))
              (ops   (-map #'car alist)))
         (unless (member op ops)
           (error "Invalid test case: %S" example))
         `(should (,fun ,actual ,expected)))))))

(defmacro exemplify-ert (fun &rest examples)
  "Define ERT tests for function FUN and its EXAMPLES.
This is the macro to use in your examples.el file."
  (declare (indent defun))
  (setq examples (-partition 3 examples))
  `(ert-deftest ,fun ()
     ,@(mapcar #'exemplify-ert-example->test examples)))

;;;;; Support

(defun exemplify-ert-libname->libfile (libname)
  "Given LIBNAME, load library and return filename it loaded from."
  (require (if (symbolp libname)
               libname
             (intern libname)))
  (--> load-history
       (-map #'car it)
       (car (-filter (lambda (lib)
                       (when (string-match
                              (format "/%s.el[cn]*$" libname)
                              lib)
                         lib))
                     it))))

(defun exemplify-ert--rw-template (from to repl)
  "Read template and make replacements.
Read template in file FROM, then write to TO after replacing
$PACKAGE with REPL."
  (--> from  f-read  (s-replace "$PACKAGE" repl it)
       (f-write it 'utf-8 to)))

;;;; Commands
;;;;; Create examples/tests file

;;;###autoload
(defun exemplify-ert-make-new ()
  "Create an 'examples/tests' file for your new project.
Run it interactively and confirm filename and directory.
\(If in doubt, go with ./dev/examples.el as suggested.)

It will also write (if not yet existent) run-tests.sh. You can use
it to run the tests from the terminal in batch mode instead of, or
in addition to, running them interactively."
  (interactive)
  (let* ((this  (exemplify-ert-libname->libfile 'exemplify-ert))
         (tmpl  (->> this  f-parent  (f-expand "templates/examples")))
         (rnts  (->> this  f-parent  (f-expand "templates/run-tests")))
         (exfl  (read-file-name
                 "Create examples file in...  " nil nil nil
                 (concat exemplify-ert-dev-subdir "/"
                         exemplify-ert-examples-filename)
                 nil))
         (pack  (read-from-minibuffer
                 "Confirm package name: "
                 (-> exfl  f-parent  f-parent  f-base)))
         (libf  (format "%s/%s.el"
                        (->> exfl  f-parent  f-parent
                             ;; in case the folder has .el
                             (s-chop-suffix ".el"))
                        ;; guess: libfile has same name as parent folder
                        pack))
         rtf)
    (mkdir (f-parent exfl) '-p)

    ;; run-tests.sh
    (setq rtf (->> exfl f-parent f-parent (f-expand "run-tests.sh")))
    (unless (f-exists? rtf)
      (exemplify-ert--rw-template rnts rtf pack)
      (set-file-modes rtf #o744))

    ;; examples.el
    (if (not (or (not (f-exists? exfl))
                 (and (y-or-n-p (s-lex-format
                                 "File ${exfl} exists. OVERWRITE?"))
                      (y-or-n-p (s-lex-format
                                 "Will overwrite ${exfl}. Are you sure?")))))
        (message "Ok, nothing done")
      (--> tmpl  f-read
           (s-replace-all `(("$PACKAGE" . ,pack)
                            ("$NAME"    . ,(if (f-exists? libf)
                                               (--> libf  lm-authors
                                                    (-map #'car it)
                                                    (s-join ", " it))
                                             "$NAME"))
                            ("$YEAR"    . ,(->> (decode-time)
                                                (nth 5)
                                                (format "%s"))))
                          it)
           (or (f-write it 'utf-8 exfl)
               (find-file exfl))))))

;;;;; Minor mode

(defcustom exemplify-ert-fontlock-add-equality-operators t
  "If non-nil, fontify equality-operators for def-examples."
  :group 'exemplify-ert
  :type 'boolean)

(defcustom exemplify-ert-fontlock-add-exemplify-ert-macros t
  "If non-nil, fontify ‘exemplify-ert’."
  :group 'exemplify-ert
  :type 'boolean)

(defun exemplify-ert--ops ()
  "Equality operators."
  (->> (-concat exemplify-ert-ops-user
                exemplify-ert-ops-default)
       (-map #'car)   (cons '!!>)   -uniq))

(defun exemplify-ert--fontlock-make-keywords ()
  "Make keywords for fontlock."
  (-non-nil
   (list (when exemplify-ert-fontlock-add-exemplify-ert-macros
           (exemplify-ert--fontlock-rx-exemplify-ert-macros))
         (when exemplify-ert-fontlock-add-equality-operators
           (exemplify-ert--fontlock-make-rx  (exemplify-ert--ops))))))

(defun exemplify-ert--fontlock-rx-exemplify-ert-macros ()
  "The rx for ‘exemplify-ert’ macros."
  `(,(rx ?\( (group (| "exemplify-ert")) symbol-end
         (+ (in "\t "))
         (group (* (| (syntax word) (syntax symbol) (: ?\\ nonl)))))
    (1 font-lock-keyword-face)
    (2 font-lock-function-name-face)))

(defun exemplify-ert--fontlock-make-rx (symbols-list)
  "Make rx using SYMBOLS-LIST."
  (let* ((strings  (-map #'symbol-name (-uniq symbols-list)))
         (rx-1    `(| ,@strings))
         (rx      `(rx symbol-start ,rx-1 symbol-end)))
    (eval rx)))

(defcustom exemplify-ert-fontify-mode-lighter nil
  "Mode line lighter for function ‘exemplify-ert-fontify-mode’.
Either a string to display in the mode line when function
‘exemplify-ert-fontify-mode’ is on, or nil to display
nothing (the default)."
  :group 'exemplify-ert
  :type '(choice (string :tag "Lighter" :value "")
                 (const  :tag "Nothing" nil)))

;;;###autoload
(define-minor-mode exemplify-ert-fontify-mode
  "Toggle fontification for Exemplify-Ert.
This is a buffer-local minor mode intended for Emacs Lisp buffers.
Enabling it causes syntax highlighting of exemplify-ert macros and
equality operators.

See also ‘exemplify-ert-fontify-mode-lighter’ and
‘global-exemplify-ert-fontify-mode’."
  :group 'exemplify-ert :lighter exemplify-ert-fontify-mode-lighter
  (if exemplify-ert-fontify-mode
      (font-lock-add-keywords nil (exemplify-ert--fontlock-make-keywords) t)
    (font-lock-remove-keywords nil (exemplify-ert--fontlock-make-keywords)))
  (cond ((fboundp 'font-lock-flush) ;; Added in Emacs 25.
         (font-lock-flush))
        ;; ‘font-lock-fontify-buffer’ unconditionally enables
        ;; ‘font-lock-mode’ and is marked ‘interactive-only’ in later
        ;; Emacs versions which have ‘font-lock-flush’, so we guard
        ;; and pacify as needed, respectively.
        (font-lock-mode
         (with-no-warnings
           (font-lock-fontify-buffer)))))

(defun exemplify-ert--turn-on-fontify-mode ()
  "Enable variable ‘exemplify-ert-fontify-mode’ if in an Emacs Lisp buffer."
  (when (derived-mode-p #'emacs-lisp-mode)
    (exemplify-ert-fontify-mode)))

;;;###autoload
(define-globalized-minor-mode global-exemplify-ert-fontify-mode
  exemplify-ert-fontify-mode exemplify-ert--turn-on-fontify-mode
  :group 'exemplify-ert)

(defcustom exemplify-ert-enable-fontlock nil
  "If t, fontify Exemplify-ERT's equality operators and ‘exemplify-ert’."
  :group 'exemplify-ert
  :set (lambda (sym val)
         (set-default sym val)
         (global-exemplify-ert-fontify-mode (if val 1 0)))
  :type 'boolean)

;;;;; See README

;;;###autoload
(defun exemplify-ert-see-readme (&optional heading narrow)
  "Open exemplify-ert's README.org file.
Search for the file in exemplify-ert.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-ert--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-ert--goto-org-heading heading narrow))
          (progress-reporter-done pr))
      (message "Couldn't find %s's README.org" exemplify-ert--name))))

(defun exemplify-ert--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))))))

;;;;; See News

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

(defun exemplify-ert--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))))

;;;; Wrapping up

(provide 'exemplify-ert)

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

;;; exemplify-ert.el ends here