flan/emacs/test-flan-mode.el

;;; test-flan-mode.el --- Indentation, from written-out shapes  -*- lexical-binding: t; -*-

;; Loaded by test-flan-cider.el, which runs under `dune test'.  It is not a
;; file of its own in test/dune deliberately: `emacs/*.el' is already a
;; dependency of that stanza, so a new `.el' here needs no build change.
;;
;; Every case is a piece of Flan written the way the corpus writes it, with
;; every line's indentation thrown away and put back.  That is the whole test:
;; if what comes out is what went in, the indenter agrees with the code that
;; already exists.  A case that is *not* in the corpus is written from
;; `clojure-mode''s behaviour and says so.
;;
;; The cases come from the bug report and from reading the tree for the shapes
;; that share it: a `let' binding vector, `defn' parameters with and without a
;; return type, `handler-bind' and `restart-case' clause parameters, and struct
;; literals in both the `:x' and the `.x' spelling — the two must agree,
;; because a lane is converting the corpus from one to the other and the
;; indenter is not allowed to notice.

;;; Code:

(require 'flan-mode)

;; The harness, which is test-flan-cider.el's: it counts and it reports, and
;; this file is loaded from there.
(declare-function test-flan--check "test-flan-cider" (name ok))

(defun test-flan-mode--reindent (text)
  "Strip TEXT's indentation and let `flan-mode' put it back."
  ;; Quiet: `indent-region' reports progress, and in batch that lands in the
  ;; middle of the line a failure is being printed on.
  (let ((inhibit-message t))
   (with-temp-buffer
    (insert text)
    (flan-mode)
    (goto-char (point-min))
    ;; Leading whitespace off every line but the first: the first line's column
    ;; is the buffer's, not the indenter's, and a form is indented relative to
    ;; where it starts.  `eobp' rather than `forward-line''s return value,
    ;; which is 0 for a move to the end of a buffer that has no final newline
    ;; and would take the whole last line with it.
    (forward-line 1)
    (while (not (eobp))
      (skip-chars-forward " \t")
      (delete-region (line-beginning-position) (point))
      (forward-line 1))
    (indent-region (point-min) (point-max))
    (buffer-substring-no-properties (point-min) (point-max)))))

(defun test-flan-mode--check (name text)
  "Check that TEXT is what `flan-mode' indents it to."
  (let ((got (test-flan-mode--reindent text)))
    (test-flan--check name (equal got text))
    (unless (equal got text)
      ;; Line by line, and quoted: the difference is always a count of leading
      ;; spaces, which is exactly what two blocks of text printed as-is make
      ;; hardest to see.
      (let ((want (split-string text "\n")) (had (split-string got "\n")))
        (while (or want had)
          (unless (equal (car want) (car had))
            (message "    want %S\n     got %S" (car want) (car had)))
          (setq want (cdr want) had (cdr had)))))))

(message "\n-- indentation")

;; The bug, as reported: sand.flan's `settle'.  The second and later bindings
;; went one column too far, because the enclosing open is `[' and the symbol
;; after it is the first binding's *name*, so the old check fell through to
;; `lisp-indent-function', which treated the vector as a call and aligned under
;; the first argument — `(+ gravity …)' — instead of under `vel'.
(test-flan-mode--check
 "a let's bindings align name under name"
 "(defn settle [row i32  col i32]
  (let [vel (+ gravity (at velocity row col))
        y   (min (- rows 1) (+ row (i32 vel)))]
    (while (> y row)
      (set y (- y 1)))))")

;; The same shape one level in, which is where the report was actually hit: a
;; binding whose value is a struct literal, so the vector's alignment has to
;; survive a `{' in the middle of it.
(test-flan-mode--check
 "and still does with a struct literal in a value"
 "(let [tip (rl/Vector2 {.x 15.0 .y 12.0})
      vel (+ gravity 1.0)]
  (draw tip vel))")

;; The two spellings must be indented identically.  Nothing in the indenter
;; looks at the key — a brace aligns under its first element whatever that
;; element is — and this is the test that keeps it that way while the corpus
;; moves from `:x' to `.x'.
(test-flan-mode--check
 "a struct literal aligns under its first field"
 "(rl/Rectangle {.x 0.0 .y 0.0
               .width  (f32 screen-width)
               .height (f32 screen-height)})")

;; The colon spelling is gone from the language — the parser refuses it — but a
;; map literal will be written this way, and the indenter must not have learned
;; the difference: it aligns under the first element of a brace and never looks
;; at what that element is spelled like.
(test-flan-mode--check
 "and a brace of keyword keys aligns exactly the same way"
 "(counts {:north 0 :south 1
         :east  2
         :west  3})")

;; `defn' carries a return type between the parameters and the body, and it is
;; optional.  Both spellings indent the body by two, which is why the spec is
;; `:defn' and not a count: a count would have to know whether the type is
;; there.
(test-flan-mode--check
 "a defn with a return type indents its body by two"
 "(defn look [n i64  label string] i64
  (print label)
  n)")

(test-flan-mode--check
 "and a defn without one indents it the same"
 "(defn show-trim [s string]
  (print s)
  (println \"\"))")

;; A parameter list that wraps is the binding-vector rule again: it is a
;; vector, so it aligns under its first element and not under its second.
(test-flan-mode--check
 "a wrapped parameter list aligns under the first parameter"
 "(defn move-grain [row i32  col i32
                  to-row i32  to-col i32
                  vel f32]
  (set moved true))")

;; `handler-bind' clauses: the vector is the special argument, and each clause
;; inside it is `(Name [params] body…)' — `defn' with the name left off.  The
;; body indents by two from the clause's own paren, which is the rule the head
;; cannot be looked up for: `StorageExhausted' is a name the program invented.
(test-flan-mode--check
 "a handler-bind clause indents its body under its own paren"
 "(handler-bind
  [(StorageExhausted [c]
     (set failures (+ failures 1))
     (invoke-restart 'retry))]
  (load-all))")

(test-flan-mode--check
 "and two clauses in one vector line up with each other"
 "(handler-bind [(AssetMissing [c] (set seen (+ seen 10)))
               (Corrupt      [c] (set other (+ other 1)))]
  (load-all))")

;; `restart-case' is 1 rather than 0: with 0 a protected form written on the
;; head's line would drag every clause out to align under it.
(test-flan-mode--check
 "restart-case clauses indent by two under a protected form on the head's line"
 "(defn fetch [n i32] i32
  (restart-case (middle n)
    (use-placeholder [] -1)
    (retry           [] 7)))")

(test-flan-mode--check
 "and by two when the protected form is on its own line"
 "(restart-case
  (do (agent/poll)
      (game-update))
  (continue [] (do)))")

;; `declare-c' writes its parameters, return type and C symbol down the page in
;; one column.
(test-flan-mode--check
 "declare-c puts everything after the name in one column"
 "(declare-c mouse-button-pressed?
  [button MouseButton] bool
  \"IsMouseButtonPressed\")")

;; An ordinary call, in the two cases every Lisp separates.
(test-flan-mode--check
 "a call with an argument on the head's line aligns under that argument"
 "(rl/draw-text \"hello\"
              10 20 30)")

(test-flan-mode--check
 "a call whose head is alone on its line indents its arguments by a body"
 "(rl/draw-rectangle-lines-ex
  (rl/Rectangle {.x 0.0 .y 0.0})
  (f32 2.0) (rl/get-color 0x303030FF))")

;; A `do' is all body, so its second form aligns under its first.
(test-flan-mode--check
 "a do aligns its forms with the first one"
 "(do (agent/poll)
    (game-update))")

;; Field access is an ordinary call whose head begins with a dot.  `.' is a
;; symbol constituent, so nothing special is needed — but if it ever stopped
;; being one, `(.x v)' would start indenting as data and this is what would
;; say so.
(test-flan-mode--check
 "field access indents as the call it is"
 "(set total
     (+ (.bytes c)
        (.align c)))")

;; `#_' discards the form after it, so the reader sees pairs either way and the
;; alignment must not shift.  See `lib/reader.ml'.
(test-flan-mode--check
 "a discarded binding does not disturb the pairs around it"
 "(let [#_a #_1 b 2
      c 3]
  (print c))")


;;; Font lock

;; The colon-to-dot change left every field label in the corpus unfontified:
;; the keyword rule used to cover them, and the colon belongs to keywords now.

(defun test-flan-mode--face-at (text needle)
  "The face on the first character of NEEDLE in TEXT, under `flan-mode'."
  (with-temp-buffer
    (insert text)
    (flan-mode)
    (font-lock-ensure)
    (goto-char (point-min))
    (search-forward needle)
    (get-text-property (- (point) (length needle)) 'face)))

(message "\n-- font lock")

(dolist (case '(("(rl/Vector2 {.x 1.0 .y 2.0})" ".x" "a struct literal's field label")
                ("(rl/Vector2 {.x 1.0 .y 2.0})" ".y" "and the second one")
                ("(set total (.bytes c))" ".bytes" "a field accessor")
                ;; The keyword rule is still there: an enum member is one.
                ("(rl/mouse-button-down? :left)" ":left" "an enum member")))
  (test-flan--check (format "%s is a constant" (nth 2 case))
                    (eq (test-flan-mode--face-at (nth 0 case) (nth 1 case))
                        'font-lock-constant-face)))

;; A dot inside a number is not a label, and neither is the dot in a name that
;; has one in the middle.
;; A dot in the middle of a name is not a label: `\_<' anchors the rule to the
;; start of a symbol, and `a.b' is one symbol starting at `a'.
(test-flan--check "a dot inside a name does not start a label"
                  (null (test-flan-mode--face-at "(f alpha.beta)" ".beta")))

(provide 'test-flan-mode)
;;; test-flan-mode.el ends here