Merge branch 'cider-inspect' into dev-loop
This commit is contained in:
commit
13e8002d39
418
emacs/flan-cnr.el
Normal file
418
emacs/flan-cnr.el
Normal file
@ -0,0 +1,418 @@
|
||||
;;; flan-cnr.el --- What a stopped program is offering -*- lexical-binding: t; -*-
|
||||
|
||||
;; `C-c C-b' is a `completing-read' over restart names. That is the whole UI
|
||||
;; for the one moment the dev loop exists to make survivable, and it is thin in
|
||||
;; a way that is worth being specific about: it shows the names and nothing
|
||||
;; else — not the condition's fields, not where the error was, not what the
|
||||
;; frame between here and the restart was doing — and it will happily let you
|
||||
;; choose a name that cannot be invoked. This is the buffer that replaces it.
|
||||
;;
|
||||
;; Two sources, and they answer different questions.
|
||||
;;
|
||||
;; **SBCL** answers *what to put first*. `invoke-debugger' prints the
|
||||
;; condition, then `show-restarts', and stops. The backtrace is a command you
|
||||
;; type, not something it shows you. That ordering is a claim: the restarts
|
||||
;; are the decision in front of you and the stack is the explanation for it,
|
||||
;; and a debugger that opens with forty frames has buried the decision under
|
||||
;; the explanation. So: condition, restarts, then the stack, and the stack's
|
||||
;; locals folded away until asked for.
|
||||
;;
|
||||
;; `show-restarts' also numbers them and brackets the name — and omits the
|
||||
;; bracket on a name already used further in. That device is not decoration.
|
||||
;; A restart is invoked by name; the name resolves to the innermost frame
|
||||
;; offering it; so a second frame offering `retry' is real, is on the list, and
|
||||
;; **cannot be chosen by name**. spec-conditions.md §4 says exactly this about
|
||||
;; Flan ("takes the first frame offering the name"), and `flan_find_restart'
|
||||
;; does exactly this in the runtime. Today's `completing-read' hides it: the
|
||||
;; list has `retry' in it twice, picking either sends the string "retry", and
|
||||
;; the inner one runs. Here the shadowed entry is drawn and refused, by name,
|
||||
;; with the reason.
|
||||
;;
|
||||
;; **CIDER's stacktrace buffer** answers *how it should behave*: frames that
|
||||
;; expand in place, TAB to fold, everything reachable from the keyboard,
|
||||
;; `q' to go. What was not taken from it is the cause chain — CIDER walks
|
||||
;; `ex-cause' because a JVM exception wraps another one, and a Flan condition
|
||||
;; wraps nothing — and its filters, which exist because a JVM backtrace is
|
||||
;; mostly frames nobody wrote.
|
||||
;;
|
||||
;; Everything this buffer cannot fill in is drawn as a section that says so, by
|
||||
;; name, with what it would take. A missing section is indistinguishable from
|
||||
;; a section that happened to be empty, and only one of those is a fact about
|
||||
;; the program.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'seq)
|
||||
(require 'subr-x)
|
||||
|
||||
(declare-function flan-dev--request "flan-dev" (form))
|
||||
(declare-function flan-inspect "flan-inspect" (expr))
|
||||
|
||||
(defgroup flan-cnr nil
|
||||
"The conditions and restarts buffer."
|
||||
:prefix "flan-cnr-"
|
||||
:group 'flan)
|
||||
|
||||
(defcustom flan-cnr-buffer "*flan-conditions*"
|
||||
"Where the break buffer draws."
|
||||
:type 'string)
|
||||
|
||||
(defvar flan-cnr-request-function #'flan-dev--request
|
||||
"How this buffer reaches the daemon.
|
||||
One plist in, the reply plist out. A variable so the renderers can be driven
|
||||
from fixtures, and so `flan-dev.el' is named in one place.")
|
||||
|
||||
;;; What is not available, and why
|
||||
|
||||
;; Said in one table rather than at each use, because these are claims about
|
||||
;; the protocol and they should be revisable in one place when a verb lands.
|
||||
;; Each carries its status in the same three words the design uses.
|
||||
|
||||
(defconst flan-cnr-unavailable
|
||||
'((layout
|
||||
. "which struct the class name refers to [needs a daemon op: `layout'. The field names and types are in `Tast.structs', which the daemon holds because it owns the build — no running program is involved. It is the one piece of this buffer that is a day's work on one side of the socket]")
|
||||
(value
|
||||
. "the break loop is handed the condition as an opaque pointer, and `break_loop' currently discards it; nothing at run time can render a value whose type it does not know [needs an agent verb: `condition', to stash and hand back the pointer, and a daemon-built render thunk aimed at it]")
|
||||
(site
|
||||
. "a restart frame carries its name and the hash matching uses, and no location [needs a location in the restart frame, which the compiler must emit]")
|
||||
(params
|
||||
. "restart arguments are checked at run time against a frame that does not record its arity [needs a field in the restart frame]")
|
||||
(stack
|
||||
. "a Flan build carries no frame metadata, so there is nothing to walk the stopped stack with [blocked: needs DWARF]")
|
||||
(locals
|
||||
. "reading a stopped frame's locals needs both the frame layout and a renderer aimed at an address rather than at an expression [blocked: needs DWARF, and the same thunk the condition's fields need]"))
|
||||
"Why a section of this buffer is empty, by name.")
|
||||
|
||||
(defun flan-cnr--why (key)
|
||||
(or (cdr (assq key flan-cnr-unavailable)) "not implemented"))
|
||||
|
||||
;;; Restarts, and which of them can actually be chosen
|
||||
|
||||
(defun flan-cnr-annotate-restarts (names)
|
||||
"Turn NAMES — innermost first — into what the buffer draws.
|
||||
Each entry is (INDEX NAME SHADOWED-BY), where SHADOWED-BY is the index of the
|
||||
earlier entry that owns the name, or nil.
|
||||
|
||||
This is §4's walk, computed here because it can be: `restart NAME' resolves
|
||||
through `flan_find_restart', which returns the first frame whose hash matches,
|
||||
so a name's second appearance is unreachable through the only verb there is.
|
||||
Nothing new has to be asked of the program to know that — the order of the
|
||||
list already says it."
|
||||
(let ((seen nil) (i -1))
|
||||
(mapcar (lambda (name)
|
||||
(setq i (1+ i))
|
||||
(let ((owner (cdr (assoc name seen))))
|
||||
(unless owner (push (cons name i) seen))
|
||||
(list i name owner)))
|
||||
names)))
|
||||
|
||||
;;; Drawing
|
||||
|
||||
(defvar-local flan-cnr--state nil
|
||||
"The plist this buffer was last drawn from.")
|
||||
(defvar-local flan-cnr--open nil
|
||||
"Indices of the frames whose locals are showing.")
|
||||
|
||||
(defun flan-cnr--unavailable (key)
|
||||
(propertize (concat " not available — " (flan-cnr--why key) "\n")
|
||||
'face 'font-lock-comment-face))
|
||||
|
||||
(defun flan-cnr--section (title)
|
||||
(insert (propertize (format "--- %s\n" title) 'face 'font-lock-comment-face)))
|
||||
|
||||
(defun flan-cnr--insert-condition (state)
|
||||
(let ((name (or (plist-get state :condition) "a condition")))
|
||||
(insert (propertize name 'face 'error))
|
||||
(insert (propertize " — unhandled; stopped on the frame that erred, nothing unwound\n"
|
||||
'face 'shadow)))
|
||||
(insert "\n")
|
||||
(flan-cnr--section "Condition fields:")
|
||||
;; Two refusals, not one, and keeping them apart is the point. The *shape* of
|
||||
;; a condition — its field names and their types — is in `Tast.structs',
|
||||
;; which the daemon holds because it owns the build; no running program is
|
||||
;; involved in answering it. Only the *values* need the pointer the break
|
||||
;; loop was handed. So a field can be named and typed while its value is
|
||||
;; refused, which is strictly more than saying nothing, and it is what tells
|
||||
;; you whether the :path you were about to blame is even a field of this
|
||||
;; condition.
|
||||
(let ((fields (plist-get state :fields)))
|
||||
(if (null fields)
|
||||
(insert (flan-cnr--unavailable 'layout))
|
||||
(let ((w (apply #'max 4 (mapcar (lambda (f) (length (nth 0 f))) fields)))
|
||||
(tw (apply #'max 4 (mapcar (lambda (f) (length (or (nth 1 f) ""))) fields))))
|
||||
(dolist (f fields)
|
||||
(let ((start (point))
|
||||
(name (nth 0 f)) (type (or (nth 1 f) "?")) (value (nth 2 f)))
|
||||
(insert (format " :%s%s %s%s " name
|
||||
(make-string (- w (length name)) ?\s)
|
||||
(propertize type 'face 'font-lock-type-face)
|
||||
(make-string (- tw (length type)) ?\s)))
|
||||
(insert (if value value
|
||||
(propertize (concat "value not available — "
|
||||
(flan-cnr--why 'value))
|
||||
'face 'font-lock-comment-face))
|
||||
"\n")
|
||||
(add-text-properties start (point)
|
||||
(list 'flan-cnr-inspect nil
|
||||
'mouse-face 'highlight)))))))
|
||||
(insert "\n"))
|
||||
|
||||
(defun flan-cnr--insert-restarts (state)
|
||||
(flan-cnr--section "Restarts (innermost first) — RET or a digit takes one:")
|
||||
(let* ((names (plist-get state :restarts))
|
||||
(rows (flan-cnr-annotate-restarts names)))
|
||||
(if (null rows)
|
||||
(insert (propertize
|
||||
" none are active. Nothing between the error and the top offered one; abort, or fix a body and reload\n"
|
||||
'face 'font-lock-comment-face))
|
||||
(let ((w (apply #'max 4 (mapcar (lambda (r) (length (nth 1 r))) rows))))
|
||||
(dolist (r rows)
|
||||
(let* ((i (nth 0 r)) (name (nth 1 r)) (owner (nth 2 r))
|
||||
(start (point)))
|
||||
;; SBCL's bracket: it is there when the name reaches this frame and
|
||||
;; gone when it does not.
|
||||
(insert (format " %2d: %s%s%s " i
|
||||
(if owner " " "[")
|
||||
(propertize name 'face
|
||||
(if owner 'shadow 'font-lock-keyword-face))
|
||||
(if owner " " "]")))
|
||||
(insert (make-string (- w (length name)) ?\s))
|
||||
(if owner
|
||||
(insert (propertize
|
||||
(format "shadowed by %d — `restart' resolves a name to the innermost frame offering it, so this one cannot be taken by name [needs an agent verb: `restart-at INDEX']" owner)
|
||||
'face 'font-lock-comment-face))
|
||||
(insert (propertize (flan-cnr--why 'site) 'face 'shadow)))
|
||||
(insert "\n")
|
||||
(add-text-properties start (point)
|
||||
(list 'flan-cnr-restart (if owner nil name)
|
||||
'flan-cnr-shadowed owner
|
||||
'flan-cnr-index i
|
||||
'mouse-face 'highlight))))))
|
||||
;; Last, and on the same list, because it is the same decision: what you
|
||||
;; pick when none of the restarts is the answer.
|
||||
(let ((start (point)))
|
||||
(insert (format " %2d: [%s] " (length rows)
|
||||
(propertize "abort" 'face 'error)))
|
||||
(insert (propertize "let the program die where it stopped; this ends `flan dev' too\n"
|
||||
'face 'shadow))
|
||||
(add-text-properties start (point)
|
||||
(list 'flan-cnr-abort t 'mouse-face 'highlight))))
|
||||
(insert "\n"))
|
||||
|
||||
(defun flan-cnr--insert-stack (state)
|
||||
(flan-cnr--section "Stack (innermost first) — TAB folds a frame's locals:")
|
||||
(let ((frames (plist-get state :stack)))
|
||||
(if (null frames)
|
||||
(insert (flan-cnr--unavailable 'stack))
|
||||
(let ((i -1))
|
||||
(dolist (fr frames)
|
||||
(setq i (1+ i))
|
||||
(let ((start (point))
|
||||
(open (memq i flan-cnr--open)))
|
||||
(insert (format " %2d: %s %s%s\n" i
|
||||
(if open "v" ">")
|
||||
(propertize (or (plist-get fr :fn) "?")
|
||||
'face 'font-lock-function-name-face)
|
||||
(if (plist-get fr :loc)
|
||||
(propertize (format " %s" (plist-get fr :loc))
|
||||
'face 'shadow)
|
||||
"")))
|
||||
(add-text-properties start (point)
|
||||
(list 'flan-cnr-frame i 'mouse-face 'highlight)))
|
||||
;; Collapsed by default. A stopped program has as many locals as it
|
||||
;; has frames, and all of them at once is the backtrace problem again
|
||||
;; one level down.
|
||||
(when (memq i flan-cnr--open)
|
||||
(let ((locals (plist-get fr :locals)))
|
||||
(if (null locals)
|
||||
(insert (flan-cnr--unavailable 'locals))
|
||||
(dolist (l locals)
|
||||
(let ((start (point)))
|
||||
(insert (format " %s %s = %s\n"
|
||||
(propertize (nth 1 l) 'face 'font-lock-type-face)
|
||||
(nth 0 l) (nth 2 l)))
|
||||
(add-text-properties start (point)
|
||||
(list 'flan-cnr-inspect (nth 0 l)
|
||||
'mouse-face 'highlight)))))))))))
|
||||
(insert "\n"))
|
||||
|
||||
(defun flan-cnr--render (state)
|
||||
"Draw STATE, a plist, into the current buffer."
|
||||
(let ((inhibit-read-only t))
|
||||
(erase-buffer)
|
||||
(setq flan-cnr--state state)
|
||||
;; SBCL's order: what happened, what you can do about it, then why.
|
||||
(flan-cnr--insert-condition state)
|
||||
(flan-cnr--insert-restarts state)
|
||||
(flan-cnr--insert-stack state)
|
||||
(insert (propertize
|
||||
"RET/0-9 take a abort TAB fold a frame i inspect g refresh q quit\n"
|
||||
'face 'shadow))
|
||||
(goto-char (point-min))))
|
||||
|
||||
;;; Commands
|
||||
|
||||
(defun flan-cnr--refuse-shadowed ()
|
||||
(user-error
|
||||
"flan: restart %d is shadowed by %d; `restart' takes a name, and this name reaches the inner frame. Taking this one needs an index verb the daemon does not have"
|
||||
(get-text-property (point) 'flan-cnr-index)
|
||||
(get-text-property (point) 'flan-cnr-shadowed)))
|
||||
|
||||
(defun flan-cnr-take ()
|
||||
"Take the restart on this line."
|
||||
(interactive)
|
||||
(cond
|
||||
((get-text-property (point) 'flan-cnr-abort) (flan-cnr-abort))
|
||||
((get-text-property (point) 'flan-cnr-shadowed) (flan-cnr--refuse-shadowed))
|
||||
((get-text-property (point) 'flan-cnr-restart)
|
||||
(flan-cnr--invoke (get-text-property (point) 'flan-cnr-restart)))
|
||||
((get-text-property (point) 'flan-cnr-frame) (flan-cnr-toggle-frame))
|
||||
(t (user-error "flan: nothing to take on this line"))))
|
||||
|
||||
(defun flan-cnr--invoke (name)
|
||||
(let ((r (funcall flan-cnr-request-function (list :op "restart" :name name))))
|
||||
(if (equal (plist-get r :status) "ok")
|
||||
;; Accepted, not resumed — the choice is validated against the stopped
|
||||
;; stack and taken when that thread next comes round its loop. So the
|
||||
;; buffer says so and goes, rather than redrawing a state that is about
|
||||
;; to stop being true.
|
||||
(progn (message "flan: %s — %s" name (or (plist-get r :note) "accepted"))
|
||||
(quit-window))
|
||||
(user-error "flan: %s" (or (plist-get r :message) "refused")))))
|
||||
|
||||
(defun flan-cnr-take-number (n)
|
||||
"Take restart number N, as SBCL's debugger does."
|
||||
(interactive (list (- last-command-event ?0)))
|
||||
(save-excursion
|
||||
(goto-char (point-min))
|
||||
(let ((found nil))
|
||||
(while (and (not found) (not (eobp)))
|
||||
(when (and (equal n (get-text-property (point) 'flan-cnr-index))
|
||||
(or (get-text-property (point) 'flan-cnr-restart)
|
||||
(get-text-property (point) 'flan-cnr-shadowed)))
|
||||
(setq found t))
|
||||
(unless found (forward-line 1)))
|
||||
(if found (flan-cnr-take)
|
||||
;; The abort line's number is one past the last restart.
|
||||
(let ((names (plist-get flan-cnr--state :restarts)))
|
||||
(if (= n (length names)) (flan-cnr-abort)
|
||||
(user-error "flan: there is no restart %d" n)))))))
|
||||
|
||||
(defun flan-cnr-abort ()
|
||||
"Let the stopped program die where it stopped."
|
||||
(interactive)
|
||||
(let ((r (funcall flan-cnr-request-function '(:op "abort"))))
|
||||
(if (equal (plist-get r :status) "ok")
|
||||
(progn (message "flan: %s" (or (plist-get r :note) "aborted")) (quit-window))
|
||||
(user-error "flan: %s" (or (plist-get r :message) "refused")))))
|
||||
|
||||
(defun flan-cnr-toggle-frame ()
|
||||
"Show or hide this frame's locals."
|
||||
(interactive)
|
||||
(let ((i (get-text-property (point) 'flan-cnr-frame)))
|
||||
(unless i (user-error "flan: point is not on a frame"))
|
||||
(setq flan-cnr--open
|
||||
(if (memq i flan-cnr--open) (delq i flan-cnr--open)
|
||||
(cons i flan-cnr--open)))
|
||||
(let ((line (line-number-at-pos)))
|
||||
(flan-cnr--render flan-cnr--state)
|
||||
(goto-char (point-min))
|
||||
(forward-line (1- line)))))
|
||||
|
||||
(defun flan-cnr-inspect ()
|
||||
"Open the inspector on the thing at point."
|
||||
(interactive)
|
||||
(let ((expr (get-text-property (point) 'flan-cnr-inspect)))
|
||||
(unless expr
|
||||
(user-error "flan: %s" (flan-cnr--why 'locals)))
|
||||
(require 'flan-inspect)
|
||||
(flan-inspect expr)))
|
||||
|
||||
(defun flan-cnr-refresh ()
|
||||
"Ask the program again what it is offering."
|
||||
(interactive)
|
||||
(flan-cnr-show))
|
||||
|
||||
(defun flan-cnr-next ()
|
||||
"Move to the next line that does something."
|
||||
(interactive)
|
||||
(let ((p (point)))
|
||||
(forward-line 1)
|
||||
(while (and (not (eobp)) (not (flan-cnr--actionable-p (point))))
|
||||
(forward-line 1))
|
||||
(when (eobp) (goto-char p))))
|
||||
|
||||
(defun flan-cnr-previous ()
|
||||
"Move to the previous line that does something."
|
||||
(interactive)
|
||||
(let ((p (point)))
|
||||
(forward-line -1)
|
||||
(while (and (not (bobp)) (not (flan-cnr--actionable-p (point))))
|
||||
(forward-line -1))
|
||||
(unless (flan-cnr--actionable-p (point)) (goto-char p))))
|
||||
|
||||
(defun flan-cnr--actionable-p (pos)
|
||||
(or (get-text-property pos 'flan-cnr-restart)
|
||||
(get-text-property pos 'flan-cnr-shadowed)
|
||||
(get-text-property pos 'flan-cnr-abort)
|
||||
(get-text-property pos 'flan-cnr-frame)
|
||||
(get-text-property pos 'flan-cnr-inspect)))
|
||||
|
||||
(defvar flan-cnr-mode-map
|
||||
(let ((map (make-sparse-keymap)))
|
||||
(define-key map (kbd "RET") #'flan-cnr-take)
|
||||
(define-key map [mouse-1] #'flan-cnr-take)
|
||||
(define-key map (kbd "TAB") #'flan-cnr-next)
|
||||
(define-key map [backtab] #'flan-cnr-previous)
|
||||
(define-key map "n" #'flan-cnr-next)
|
||||
(define-key map "p" #'flan-cnr-previous)
|
||||
(define-key map "f" #'flan-cnr-toggle-frame)
|
||||
(define-key map "i" #'flan-cnr-inspect)
|
||||
(define-key map "a" #'flan-cnr-abort)
|
||||
(define-key map "g" #'flan-cnr-refresh)
|
||||
(define-key map "q" #'quit-window)
|
||||
;; Numbered, as SBCL's are, and for SBCL's reason: the names are not
|
||||
;; unique, so the number is the only unambiguous handle a person has.
|
||||
(dotimes (i 10)
|
||||
(define-key map (kbd (number-to-string i)) #'flan-cnr-take-number))
|
||||
map)
|
||||
"Keys in `flan-cnr-mode'.")
|
||||
|
||||
(define-derived-mode flan-cnr-mode special-mode "flan-break"
|
||||
"What a stopped Flan program is offering."
|
||||
(setq buffer-read-only t))
|
||||
|
||||
(defun flan-cnr-state-from-reply (reply)
|
||||
"The buffer's state, out of a `break' REPLY.
|
||||
Everything this cannot fill in is left nil deliberately: the renderer draws a
|
||||
section saying why rather than leaving one out, and a section that is absent
|
||||
cannot be told from one that is empty."
|
||||
(list :condition (plist-get reply :condition)
|
||||
:restarts (plist-get reply :restarts)
|
||||
;; Both nil deliberately: `break' answers a class name and a list of
|
||||
;; restart names, and nothing else exists to put here yet. The renderer
|
||||
;; draws a section saying why rather than leaving one out.
|
||||
:fields nil
|
||||
:stack nil
|
||||
:locals nil))
|
||||
|
||||
;;;###autoload
|
||||
(defun flan-cnr-show ()
|
||||
"Show what the stopped program is offering, in a buffer.
|
||||
Refuses while the program is running, by name: there is no restart stack to
|
||||
walk from a running program."
|
||||
(interactive)
|
||||
(let ((r (funcall flan-cnr-request-function '(:op "break"))))
|
||||
(unless (equal (plist-get r :status) "ok")
|
||||
(user-error "flan: %s" (or (plist-get r :message) "refused")))
|
||||
(unless (plist-get r :stopped)
|
||||
(user-error "flan: the program is running; there is no restart stack to walk"))
|
||||
(let ((buf (get-buffer-create flan-cnr-buffer)))
|
||||
(with-current-buffer buf
|
||||
(unless (derived-mode-p 'flan-cnr-mode) (flan-cnr-mode))
|
||||
(flan-cnr--render (flan-cnr-state-from-reply r)))
|
||||
(pop-to-buffer buf)
|
||||
buf)))
|
||||
|
||||
(provide 'flan-cnr)
|
||||
;;; flan-cnr.el ends here
|
||||
452
emacs/flan-inspect.el
Normal file
452
emacs/flan-inspect.el
Normal file
@ -0,0 +1,452 @@
|
||||
;;; flan-inspect.el --- Navigate a running program's values -*- lexical-binding: t; -*-
|
||||
|
||||
;; `C-x C-e' renders a value once and puts it in the echo area. This is the
|
||||
;; interactive version of the same walk: the fields laid out one per line, RET
|
||||
;; to go into one, `l' to come back, `g' to read it again. CIDER's inspector,
|
||||
;; adapted — and the adaptation is the whole design, so it is worth stating
|
||||
;; what changed and why.
|
||||
;;
|
||||
;; CIDER's inspector keeps its stack **on the server**. `inspect-push' hands
|
||||
;; the middleware an index and the middleware walks into the object it is
|
||||
;; already holding; the client's own stack is only remembered point positions.
|
||||
;; That is available to it because a JVM value can be retained: the middleware
|
||||
;; keeps a reference and the collector leaves it alone.
|
||||
;;
|
||||
;; Nothing here can do that. A Flan value has no header, the thunk that
|
||||
;; rendered it is `dlclose'd the moment it returns, and there is no heap to
|
||||
;; retain anything in. So the stack is a stack of **expressions**, on this
|
||||
;; side, and going into a field means sending a *different expression* —
|
||||
;; `(.pos b)' where the last one was `b'. Two consequences, one good and one
|
||||
;; that has to be said out loud:
|
||||
;;
|
||||
;; the view is never stale. Every step and every `g' reads the program as
|
||||
;; it is now, at a frame boundary it agreed to stop on. CIDER's inspector
|
||||
;; shows you the object as it was when you pushed;
|
||||
;;
|
||||
;; and the root expression runs again on every step. Appending a field
|
||||
;; accessor to it is pure, but the root need not be — `(spawn-enemy)' as a
|
||||
;; root spawns one per keystroke. Which is why there is no auto-refresh and
|
||||
;; why `g' is a key someone presses.
|
||||
;;
|
||||
;; The other thing this buys, and the reason it is worth having at all next to
|
||||
;; `C-x C-e': the renderer bounds its walk at depth 4 and span 8
|
||||
;; (lib/session.ml). A field past either bound comes back as `...' and no
|
||||
;; amount of squinting at the echo area recovers it. Re-rooting the walk at
|
||||
;; that field renders it from depth 0 — the bound moves with you.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'seq)
|
||||
(require 'subr-x)
|
||||
|
||||
(declare-function flan-dev--request "flan-dev" (form))
|
||||
|
||||
(defgroup flan-inspect nil
|
||||
"Navigating values in a running Flan program."
|
||||
:prefix "flan-inspect-"
|
||||
:group 'flan)
|
||||
|
||||
(defcustom flan-inspect-buffer "*flan-inspect*"
|
||||
"Where the inspector draws."
|
||||
:type 'string)
|
||||
|
||||
(defvar flan-inspect-request-function #'flan-dev--request
|
||||
"How the inspector reaches the program.
|
||||
Called with one plist — a request — and returning the reply plist. It is a
|
||||
variable rather than a direct call so that a test can hand the renderers a
|
||||
reply without a daemon behind them, and so that this file names
|
||||
`flan-dev.el' in exactly one place.")
|
||||
|
||||
;;; Reading what the renderer wrote
|
||||
|
||||
;; The value comes back as a string, and that string is very nearly an
|
||||
;; s-expression — `(Blob {:id 7 :pos (V {:x 1.5 :y 0})})'. Nearly, because
|
||||
;; Emacs' `read' has no `{', so it is parsed here instead. The grammar is
|
||||
;; small and fixed by `Session.render' (lib/session.ml), and every case below
|
||||
;; names the line of it that produces it.
|
||||
;;
|
||||
;; (Name {:f V :f V}) a struct, with ` ...' before the `}' if the walk hit
|
||||
;; its span bound of 8 fields
|
||||
;; [ V V V] an array or a slice, ` ...' likewise
|
||||
;; (some V) / none an option
|
||||
;; <ptr> a pointer, never followed
|
||||
;; <Name> a named type the walk had no structure for
|
||||
;; ... the depth bound, 4, reached at this position
|
||||
;; :name an enum member, or its number if it matched none
|
||||
;; "…" a string, escaped in C
|
||||
;; true / false / () bool, and the value of a Unit expression
|
||||
;; 1.5 / 7 / 18446… a number
|
||||
;;
|
||||
;; A node is a plist: :kind, :text (what the renderer wrote for it), :type
|
||||
;; where there is one, and :children as a list of (LABEL . NODE).
|
||||
|
||||
(defun flan-inspect--skip-space (s i)
|
||||
(while (and (< i (length s)) (memq (aref s i) '(?\s ?\n ?\t))) (setq i (1+ i)))
|
||||
i)
|
||||
|
||||
(defun flan-inspect--read-string (s i)
|
||||
"Read a quoted string starting at I (which is the opening quote)."
|
||||
(let ((out (list ?\")) (i (1+ i)) (done nil))
|
||||
(while (and (not done) (< i (length s)))
|
||||
(let ((c (aref s i)))
|
||||
(cond ((eq c ?\\)
|
||||
(setq i (1+ i))
|
||||
(when (< i (length s)) (push (aref s i) out) (setq i (1+ i))))
|
||||
((eq c ?\") (push ?\" out) (setq i (1+ i)) (setq done t))
|
||||
(t (push c out) (setq i (1+ i))))))
|
||||
(cons (list :kind 'atom :text (concat (nreverse out))) i)))
|
||||
|
||||
(defun flan-inspect--read-atom (s i)
|
||||
"Read a bare token at I: a number, a keyword, `true', `none', `...'."
|
||||
(let ((start i))
|
||||
(while (and (< i (length s))
|
||||
(not (memq (aref s i) '(?\s ?\n ?\t ?\) ?\] ?\}))))
|
||||
(setq i (1+ i)))
|
||||
(let ((text (substring s start i)))
|
||||
(cons (list :kind (if (equal text "...") 'trunc 'atom) :text text) i))))
|
||||
|
||||
(defun flan-inspect--read-angle (s i)
|
||||
"Read `<ptr>' or `<Name>' at I."
|
||||
(let ((end (or (string-match ">" s i) (1- (length s)))))
|
||||
(let ((text (substring s i (1+ end))))
|
||||
(cons (list :kind (if (equal text "<ptr>") 'ptr 'opaque) :text text)
|
||||
(1+ end)))))
|
||||
|
||||
(defun flan-inspect--read-seq (s i)
|
||||
"Read `[ V V]' at I, which is `[' — an array or a slice."
|
||||
(let ((i (1+ i)) (kids nil) (n 0) (more nil) (done nil))
|
||||
(while (not done)
|
||||
(setq i (flan-inspect--skip-space s i))
|
||||
(cond
|
||||
((>= i (length s)) (setq done t))
|
||||
((eq (aref s i) ?\]) (setq i (1+ i)) (setq done t))
|
||||
(t (let ((r (flan-inspect--read s i)))
|
||||
(setq i (cdr r))
|
||||
;; A bare `...' inside a sequence is the renderer saying it stopped,
|
||||
;; not an element. It is the last thing it writes either way.
|
||||
(if (eq (plist-get (car r) :kind) 'trunc)
|
||||
(setq more t)
|
||||
(push (cons n (car r)) kids)
|
||||
(setq n (1+ n)))))))
|
||||
(cons (list :kind 'seq
|
||||
:text (format "%d element%s%s" n (if (= n 1) "" "s")
|
||||
(if more ", and more the renderer did not write" ""))
|
||||
:truncated more
|
||||
:children (nreverse kids))
|
||||
i)))
|
||||
|
||||
(defun flan-inspect--read-struct (s i)
|
||||
"Read `(Name {…})' or `(some V)' at I, which is `('."
|
||||
(let ((j (1+ i)))
|
||||
(let ((start j))
|
||||
(while (and (< j (length s)) (not (memq (aref s j) '(?\s ?\))))) (setq j (1+ j)))
|
||||
(let ((head (substring s start j)))
|
||||
(cond
|
||||
;; (some V). There is no accessor form in Flan that reaches an
|
||||
;; option's payload — the compiler gets at it as field 1 and nothing
|
||||
;; in the surface language does — so this parses, prints, and refuses
|
||||
;; to be entered.
|
||||
((equal head "some")
|
||||
(let* ((r (flan-inspect--read s (flan-inspect--skip-space s j)))
|
||||
(k (flan-inspect--skip-space s (cdr r))))
|
||||
(cons (list :kind 'option :text "some" :type "Option"
|
||||
:children (list (cons "some" (car r))))
|
||||
(if (and (< k (length s)) (eq (aref s k) ?\))) (1+ k) k))))
|
||||
(t
|
||||
;; `(Name {' then `:field VALUE' pairs, then `})'.
|
||||
(setq j (flan-inspect--skip-space s j))
|
||||
(when (and (< j (length s)) (eq (aref s j) ?\{)) (setq j (1+ j)))
|
||||
(let ((kids nil) (more nil) (done nil))
|
||||
(while (not done)
|
||||
(setq j (flan-inspect--skip-space s j))
|
||||
(cond
|
||||
((>= j (length s)) (setq done t))
|
||||
((eq (aref s j) ?\}) (setq j (1+ j)) (setq done t))
|
||||
((eq (aref s j) ?:)
|
||||
(let ((start j))
|
||||
(while (and (< j (length s)) (not (memq (aref s j) '(?\s ?\}))))
|
||||
(setq j (1+ j)))
|
||||
(let ((name (substring s (1+ start) j))
|
||||
(r (flan-inspect--read s (flan-inspect--skip-space s j))))
|
||||
(setq j (cdr r))
|
||||
(push (cons name (car r)) kids))))
|
||||
(t (let ((r (flan-inspect--read s j)))
|
||||
(setq j (cdr r))
|
||||
(if (eq (plist-get (car r) :kind) 'trunc)
|
||||
(setq more t)
|
||||
;; Not a `:field' and not `...'. Rather than guess, keep
|
||||
;; it where it was written.
|
||||
(push (cons "?" (car r)) kids))))))
|
||||
(setq j (flan-inspect--skip-space s j))
|
||||
(when (and (< j (length s)) (eq (aref s j) ?\))) (setq j (1+ j)))
|
||||
(cons (list :kind 'struct :text head :type head
|
||||
:truncated more
|
||||
:children (nreverse kids))
|
||||
j))))))))
|
||||
|
||||
(defun flan-inspect--read (s i)
|
||||
"Read one rendered value out of S at I. Returns (NODE . NEXT-INDEX)."
|
||||
(let ((i (flan-inspect--skip-space s i)))
|
||||
(if (>= i (length s))
|
||||
(cons (list :kind 'atom :text "") i)
|
||||
(pcase (aref s i)
|
||||
(?\( (flan-inspect--read-struct s i))
|
||||
(?\[ (flan-inspect--read-seq s i))
|
||||
(?\" (flan-inspect--read-string s i))
|
||||
(?< (flan-inspect--read-angle s i))
|
||||
(_ (flan-inspect--read-atom s i))))))
|
||||
|
||||
(defun flan-inspect-parse (rendered)
|
||||
"Parse RENDERED — what the daemon put in a reply's :value — into a node."
|
||||
(car (flan-inspect--read (or rendered "") 0)))
|
||||
|
||||
;;; Where a field is, said in Flan
|
||||
|
||||
;; A step is not an index into something remembered; it is a piece of source.
|
||||
;; `(.pos b)' and `(at (.tags b) 2)' are expressions the program can be handed
|
||||
;; exactly as a person would type them, which is what makes the whole thing
|
||||
;; work without a handle to retain.
|
||||
|
||||
(defun flan-inspect-step-expr (expr step)
|
||||
"The Flan expression reaching STEP inside EXPR."
|
||||
(pcase step
|
||||
(`(:field ,name) (format "(.%s %s)" name expr))
|
||||
(`(:index ,i) (format "(at %s %d)" expr i))
|
||||
(_ expr)))
|
||||
|
||||
;;; Why a thing cannot be entered
|
||||
|
||||
;; Every refusal is by name and carries its reason, because the alternative —
|
||||
;; RET doing nothing on some lines and something on others — is a UI that
|
||||
;; teaches you nothing about the language.
|
||||
|
||||
(defun flan-inspect-refusal (node)
|
||||
"Why NODE cannot be inspected, or nil if it can."
|
||||
(pcase (plist-get node :kind)
|
||||
('struct (and (null (plist-get node :children))
|
||||
"a struct with no fields the renderer could reach"))
|
||||
('seq (and (null (plist-get node :children))
|
||||
"an empty sequence: there is no element to go into"))
|
||||
('option
|
||||
"an option's payload: Flan has no accessor form that reaches it, so there is no expression to send")
|
||||
('ptr
|
||||
"a pointer: the renderer never follows one, and dereferencing a pointer on your behalf is not safe")
|
||||
('trunc
|
||||
"truncated: the walk stopped at its depth bound of 4. Inspect the field that holds it, which re-roots the walk")
|
||||
('opaque
|
||||
(format "%s: the walk had no structure for this type, so there are no fields to show"
|
||||
(plist-get node :text)))
|
||||
('atom (format "%s is an atom; it has no fields" (plist-get node :text)))
|
||||
(_ "not something this inspector knows how to enter")))
|
||||
|
||||
;;; Drawing it
|
||||
|
||||
(defvar-local flan-inspect--stack nil
|
||||
"Where we have been: a list of (EXPR . POINT), innermost last-pushed first.")
|
||||
(defvar-local flan-inspect--expr nil "The expression this buffer is showing.")
|
||||
(defvar-local flan-inspect--node nil "Its parsed value.")
|
||||
|
||||
(defun flan-inspect--label (child)
|
||||
(let ((k (car child)))
|
||||
(if (integerp k) (format "%d." k) (format ":%s" k))))
|
||||
|
||||
(defun flan-inspect--summary (node)
|
||||
"One line for NODE, as it appears beside its label."
|
||||
(pcase (plist-get node :kind)
|
||||
('struct (format "(%s …%s)" (plist-get node :type)
|
||||
(let ((n (length (plist-get node :children))))
|
||||
(format " %d field%s" n (if (= n 1) "" "s")))))
|
||||
('seq (plist-get node :text))
|
||||
('option (format "(some …)"))
|
||||
(_ (plist-get node :text))))
|
||||
|
||||
(defun flan-inspect--render (expr node stack)
|
||||
"Draw NODE, reached by EXPR, with STACK behind it."
|
||||
(let ((inhibit-read-only t))
|
||||
(erase-buffer)
|
||||
(insert (propertize expr 'face 'font-lock-function-name-face) "\n")
|
||||
(insert (propertize
|
||||
(pcase (plist-get node :kind)
|
||||
('struct (format "a %s\n" (plist-get node :type)))
|
||||
('seq (format "%s\n" (plist-get node :text)))
|
||||
('option "an option\n")
|
||||
('ptr "a pointer — never followed\n")
|
||||
(_ (format "%s\n" (plist-get node :text))))
|
||||
'face 'font-lock-type-face))
|
||||
;; The stack made visible. CIDER keeps it and does not show it; here it is
|
||||
;; the difference between a value and *which* value, and the thing that was
|
||||
;; typed at the root is often several steps back by now.
|
||||
(when stack
|
||||
(insert (propertize
|
||||
(concat " via "
|
||||
(string-join (reverse (mapcar #'car stack)) " > ")
|
||||
" > here\n")
|
||||
'face 'shadow)))
|
||||
(insert "\n")
|
||||
(let ((kids (plist-get node :children)))
|
||||
(cond
|
||||
(kids
|
||||
(insert (propertize (if (eq (plist-get node :kind) 'seq)
|
||||
"--- Elements:\n" "--- Fields:\n")
|
||||
'face 'font-lock-comment-face))
|
||||
(let ((w (apply #'max 4 (mapcar (lambda (c) (length (flan-inspect--label c))) kids))))
|
||||
(dolist (c kids)
|
||||
(let* ((label (flan-inspect--label c))
|
||||
(child (cdr c))
|
||||
(step (if (integerp (car c)) (list :index (car c))
|
||||
(list :field (car c))))
|
||||
(start (point)))
|
||||
(insert (format " %s%s " label
|
||||
(make-string (- w (length label)) ?\s)))
|
||||
(insert (flan-inspect--summary child) "\n")
|
||||
(add-text-properties
|
||||
start (point)
|
||||
(list 'flan-inspect-step step
|
||||
'flan-inspect-node child
|
||||
'mouse-face 'highlight)))))
|
||||
(when (plist-get node :truncated)
|
||||
(insert (propertize
|
||||
" ... the renderer stopped at its span bound of 8; the rest was not written\n"
|
||||
'face 'font-lock-warning-face))))
|
||||
(t
|
||||
(insert (propertize
|
||||
(format "Nothing to go into: %s\n" (flan-inspect-refusal node))
|
||||
'face 'font-lock-comment-face)))))
|
||||
(insert "\n")
|
||||
(insert (propertize
|
||||
"RET inspect l back g refresh TAB/n next p previous q quit\n"
|
||||
'face 'shadow))
|
||||
(goto-char (point-min))))
|
||||
|
||||
;;; The commands
|
||||
|
||||
(defun flan-inspect--value (expr)
|
||||
"Ask the program for EXPR's value, rendered. Signals if it refuses."
|
||||
(let ((r (funcall flan-inspect-request-function
|
||||
(list :op "eval-expr" :code expr :file "<inspect>"))))
|
||||
(unless (equal (plist-get r :status) "ok")
|
||||
(user-error "flan: %s" (or (plist-get r :message) "refused")))
|
||||
(or (plist-get r :value)
|
||||
(user-error "flan: the program answered without a value for %s" expr))))
|
||||
|
||||
(defun flan-inspect--show (expr &optional stack)
|
||||
"Render EXPR in the inspector buffer, with STACK behind it."
|
||||
(let ((value (flan-inspect--value expr))
|
||||
(buf (get-buffer-create flan-inspect-buffer)))
|
||||
(with-current-buffer buf
|
||||
(unless (derived-mode-p 'flan-inspect-mode) (flan-inspect-mode))
|
||||
(setq flan-inspect--expr expr)
|
||||
(setq flan-inspect--node (flan-inspect-parse value))
|
||||
(setq flan-inspect--stack stack)
|
||||
(flan-inspect--render expr flan-inspect--node stack))
|
||||
(display-buffer buf)
|
||||
buf))
|
||||
|
||||
;;;###autoload
|
||||
(defun flan-inspect (expr)
|
||||
"Inspect the value of EXPR in the running program.
|
||||
Interactively, the expression before point, or one you type."
|
||||
(interactive
|
||||
(list (read-string "Inspect: "
|
||||
(ignore-errors
|
||||
(buffer-substring-no-properties
|
||||
(save-excursion (backward-sexp) (point)) (point))))))
|
||||
(flan-inspect--show expr nil))
|
||||
|
||||
(defun flan-inspect-into ()
|
||||
"Go into the field or element at point."
|
||||
(interactive)
|
||||
(let ((step (get-text-property (point) 'flan-inspect-step))
|
||||
(node (get-text-property (point) 'flan-inspect-node)))
|
||||
(unless step (user-error "flan: nothing to inspect on this line"))
|
||||
(let ((why (flan-inspect-refusal node)))
|
||||
(when why (user-error "flan: %s" why)))
|
||||
(let ((expr (flan-inspect-step-expr flan-inspect--expr step))
|
||||
(stack (cons (cons flan-inspect--expr (point)) flan-inspect--stack)))
|
||||
(flan-inspect--show expr stack))))
|
||||
|
||||
(defun flan-inspect-pop ()
|
||||
"Back to the value you came from, at the line you left."
|
||||
(interactive)
|
||||
(unless flan-inspect--stack
|
||||
(user-error "flan: this is the root; there is nothing behind it"))
|
||||
(let* ((top (car flan-inspect--stack))
|
||||
(rest (cdr flan-inspect--stack)))
|
||||
(flan-inspect--show (car top) rest)
|
||||
(with-current-buffer flan-inspect-buffer
|
||||
(goto-char (min (cdr top) (point-max))))))
|
||||
|
||||
(defun flan-inspect-refresh ()
|
||||
"Read the same expression again.
|
||||
Deliberately a key rather than a timer: the expression runs in the program,
|
||||
and a root with an effect in it would fire once a second forever."
|
||||
(interactive)
|
||||
(unless flan-inspect--expr (user-error "flan: nothing is being inspected"))
|
||||
(let ((p (point)))
|
||||
(flan-inspect--show flan-inspect--expr flan-inspect--stack)
|
||||
(with-current-buffer flan-inspect-buffer (goto-char (min p (point-max))))))
|
||||
|
||||
(defun flan-inspect--fields ()
|
||||
"The start of every inspectable line, in order.
|
||||
Both movement commands go through this rather than walking property changes
|
||||
by hand: a field line has the property on all of it, so `next-single-...'
|
||||
from the middle of one finds the *end* of the line you are already on, and
|
||||
forward and backward then disagree about where a field begins."
|
||||
(let ((out nil) (p (point-min)))
|
||||
(while (< p (point-max))
|
||||
;; A new field begins where the property's *value* changes, not where the
|
||||
;; property appears: field lines are contiguous, so the last character of
|
||||
;; one carries a step just as the first character of the next does.
|
||||
(when (and (get-text-property p 'flan-inspect-step)
|
||||
(or (= p (point-min))
|
||||
(not (equal (get-text-property p 'flan-inspect-step)
|
||||
(get-text-property (1- p) 'flan-inspect-step)))))
|
||||
(push p out))
|
||||
(setq p (1+ p)))
|
||||
(nreverse out)))
|
||||
|
||||
(defun flan-inspect-next (&optional n)
|
||||
"Move to the next inspectable line. With N, that many.
|
||||
Wraps, as CIDER's does: a list you have walked off the end of should come
|
||||
back round rather than stop dead."
|
||||
(interactive "p")
|
||||
(let ((fields (flan-inspect--fields)))
|
||||
(unless fields (user-error "flan: there is nothing to move between"))
|
||||
(dotimes (_ (or n 1))
|
||||
(goto-char (or (seq-find (lambda (p) (> p (point))) fields)
|
||||
(car fields))))))
|
||||
|
||||
(defun flan-inspect-previous (&optional n)
|
||||
"Move to the previous inspectable line. With N, that many.
|
||||
Wraps too — the same list, walked the other way, and an asymmetry here is
|
||||
the kind of thing nobody reports and everybody notices."
|
||||
(interactive "p")
|
||||
(let ((fields (flan-inspect--fields)))
|
||||
(unless fields (user-error "flan: there is nothing to move between"))
|
||||
(dotimes (_ (or n 1))
|
||||
(goto-char (or (seq-find (lambda (p) (< p (point))) (reverse fields))
|
||||
(car (last fields)))))))
|
||||
|
||||
(defvar flan-inspect-mode-map
|
||||
(let ((map (make-sparse-keymap)))
|
||||
;; CIDER's, and the same letters mean the same things: someone who has used
|
||||
;; one should not have to learn the other.
|
||||
(define-key map (kbd "RET") #'flan-inspect-into)
|
||||
(define-key map [mouse-1] #'flan-inspect-into)
|
||||
(define-key map "l" #'flan-inspect-pop)
|
||||
(define-key map "g" #'flan-inspect-refresh)
|
||||
(define-key map (kbd "TAB") #'flan-inspect-next)
|
||||
(define-key map "n" #'flan-inspect-next)
|
||||
(define-key map [backtab] #'flan-inspect-previous)
|
||||
(define-key map "p" #'flan-inspect-previous)
|
||||
(define-key map "q" #'quit-window)
|
||||
map)
|
||||
"Keys in `flan-inspect-mode'.")
|
||||
|
||||
(define-derived-mode flan-inspect-mode special-mode "flan-inspect"
|
||||
"Look at a value in the running Flan program."
|
||||
(setq buffer-read-only t)
|
||||
(setq-local truncate-lines t))
|
||||
|
||||
(provide 'flan-inspect)
|
||||
;;; flan-inspect.el ends here
|
||||
484
emacs/test-flan-cider.el
Normal file
484
emacs/test-flan-cider.el
Normal file
@ -0,0 +1,484 @@
|
||||
;;; test-flan-cider.el --- The inspector and break buffers, from fixtures -*- lexical-binding: t; -*-
|
||||
|
||||
;; Run as: emacs -Q --batch -L emacs -l emacs/test-flan-cider.el
|
||||
;;
|
||||
;; Nothing here needs a daemon or a running program, and that is deliberate
|
||||
;; rather than a shortcut. Both buffers are functions from *a reply's data* to
|
||||
;; *text with properties on it*, and the interesting failures are all on that
|
||||
;; side: a struct the reader mis-parses, a shadowed restart drawn as though it
|
||||
;; could be chosen, a section quietly omitted instead of refused. Driving it
|
||||
;; from fixtures tests exactly that, and it tests the cases a live program
|
||||
;; cannot easily be made to produce — a value past the renderer's depth bound,
|
||||
;; two restarts with one name, a frame with locals in it at all.
|
||||
;;
|
||||
;; The fixtures are not invented. Every rendered string below is the shape
|
||||
;; `Session.render' writes, case by case, and the comment on each says which.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'flan-inspect)
|
||||
(require 'flan-cnr)
|
||||
|
||||
(defvar test-flan--failures 0)
|
||||
(defvar test-flan--ran 0)
|
||||
|
||||
(defun test-flan--check (name ok)
|
||||
(setq test-flan--ran (1+ test-flan--ran))
|
||||
(if ok (message " ok %s" name)
|
||||
(setq test-flan--failures (1+ test-flan--failures))
|
||||
(message " FAIL %s" name)))
|
||||
|
||||
(defun test-flan--text (thunk)
|
||||
"Run THUNK in a scratch buffer and return what it drew."
|
||||
(with-temp-buffer
|
||||
(funcall thunk)
|
||||
(buffer-substring-no-properties (point-min) (point-max))))
|
||||
|
||||
(defun test-flan--caught (thunk)
|
||||
"The message of the error THUNK signals, or nil if it does not."
|
||||
(condition-case e (progn (funcall thunk) nil)
|
||||
(error (error-message-string e))))
|
||||
|
||||
|
||||
;;; The reader
|
||||
|
||||
(message "\nreading what the renderer wrote")
|
||||
|
||||
;; (V {:x 1.5 :y 0}) — Types.Named, lib/session.ml.
|
||||
(let ((n (flan-inspect-parse "(V {:x 1.5 :y 0})")))
|
||||
(test-flan--check "a struct is a struct" (eq (plist-get n :kind) 'struct))
|
||||
(test-flan--check "with its type name" (equal (plist-get n :type) "V"))
|
||||
(test-flan--check "and its fields in order"
|
||||
(equal (mapcar #'car (plist-get n :children)) '("x" "y")))
|
||||
(test-flan--check "carrying their values"
|
||||
(equal (plist-get (cdr (assoc "x" (plist-get n :children))) :text)
|
||||
"1.5")))
|
||||
|
||||
;; The whole of NEXT.md's worked example, nested two deep with a string that
|
||||
;; has escaped quotes in it and a slice at the end.
|
||||
(let* ((src "(Blob {:id 7 :name \"sandy \\\"quoted\\\"\" :pos (V {:x 1.5 :y 0}) :tags [ 0 42 0]})")
|
||||
(n (flan-inspect-parse src))
|
||||
(kids (plist-get n :children)))
|
||||
(test-flan--check "every field of a nested struct"
|
||||
(equal (mapcar #'car kids) '("id" "name" "pos" "tags")))
|
||||
(test-flan--check "an escaped quote does not end the string early"
|
||||
(equal (plist-get (cdr (assoc "name" kids)) :text)
|
||||
"\"sandy \"quoted\"\""))
|
||||
(test-flan--check "a struct inside a struct"
|
||||
(equal (plist-get (cdr (assoc "pos" kids)) :type) "V"))
|
||||
(test-flan--check "a slice inside a struct, with its elements"
|
||||
(equal (mapcar #'car (plist-get (cdr (assoc "tags" kids)) :children))
|
||||
'(0 1 2))))
|
||||
|
||||
;; [ 0 42 0] — Types.Slice and Types.Array both write this.
|
||||
(let ((n (flan-inspect-parse "[ 0 42 0]")))
|
||||
(test-flan--check "a sequence is a sequence" (eq (plist-get n :kind) 'seq))
|
||||
(test-flan--check "indexed from zero"
|
||||
(equal (mapcar #'car (plist-get n :children)) '(0 1 2))))
|
||||
|
||||
;; [ [ 0 0] [ 1 ...] ...] — span truncation at both levels, which is what
|
||||
;; sand's [100 [100 u32]] actually produces.
|
||||
(let* ((n (flan-inspect-parse "[ [ 0 0] [ 1 ...] ...]"))
|
||||
(kids (plist-get n :children)))
|
||||
(test-flan--check "a trailing ... is truncation, not an element"
|
||||
(and (= (length kids) 2) (plist-get n :truncated)))
|
||||
(test-flan--check "and it is noticed on the inner sequence too"
|
||||
(plist-get (cdr (nth 1 kids)) :truncated)))
|
||||
|
||||
;; The renderer's refusals, each of which becomes a leaf here.
|
||||
(test-flan--check "a pointer is a pointer"
|
||||
(eq (plist-get (flan-inspect-parse "<ptr>") :kind) 'ptr))
|
||||
(test-flan--check "a type the walk had no structure for"
|
||||
(eq (plist-get (flan-inspect-parse "<Widget>") :kind) 'opaque))
|
||||
(test-flan--check "the depth bound"
|
||||
(eq (plist-get (flan-inspect-parse "...") :kind) 'trunc))
|
||||
(test-flan--check "an option"
|
||||
(eq (plist-get (flan-inspect-parse "(some 3)") :kind) 'option))
|
||||
(test-flan--check "an enum member is an atom, not a field"
|
||||
(eq (plist-get (flan-inspect-parse ":blue") :kind) 'atom))
|
||||
(test-flan--check "and so is a u64 that fills the range"
|
||||
(equal (plist-get (flan-inspect-parse "18446744073709551615") :text)
|
||||
"18446744073709551615"))
|
||||
|
||||
;; A struct with a `...' where a field would be: span truncation *inside* a
|
||||
;; struct, which is a different position in the grammar from a sequence's.
|
||||
(let ((n (flan-inspect-parse "(Wide {:a 1 :b 2 ...})")))
|
||||
(test-flan--check "a struct's span bound is truncation, not a field"
|
||||
(and (equal (mapcar #'car (plist-get n :children)) '("a" "b"))
|
||||
(plist-get n :truncated))))
|
||||
|
||||
|
||||
;;; Where a field is, said in Flan
|
||||
|
||||
(message "\nthe path is an expression")
|
||||
|
||||
(test-flan--check "a field is a field accessor"
|
||||
(equal (flan-inspect-step-expr "b" '(:field "pos")) "(.pos b)"))
|
||||
(test-flan--check "an element is `at'"
|
||||
(equal (flan-inspect-step-expr "(.tags b)" '(:index 2))
|
||||
"(at (.tags b) 2)"))
|
||||
(test-flan--check "and they compose, which is the whole trick"
|
||||
(equal (flan-inspect-step-expr
|
||||
(flan-inspect-step-expr "b" '(:field "pos")) '(:field "x"))
|
||||
"(.x (.pos b))"))
|
||||
|
||||
|
||||
;;; Refusals, by name, with the reason
|
||||
|
||||
(message "\nwhat cannot be entered says so")
|
||||
|
||||
(dolist (case '(("<ptr>" "pointer") ("..." "depth bound") ("7" "atom")
|
||||
("(some 3)" "accessor form") ("<Widget>" "no structure")))
|
||||
(let ((why (flan-inspect-refusal (flan-inspect-parse (car case)))))
|
||||
(test-flan--check (format "%s refuses, naming %s" (car case) (cadr case))
|
||||
(and why (string-match-p (regexp-quote (cadr case)) why)))))
|
||||
|
||||
(test-flan--check "a struct with fields does not refuse"
|
||||
(null (flan-inspect-refusal (flan-inspect-parse "(V {:x 1 :y 2})"))))
|
||||
|
||||
|
||||
;;; The inspector buffer
|
||||
|
||||
(message "\nthe inspector buffer")
|
||||
|
||||
(defun test-flan--inspect (expr rendered)
|
||||
"Draw EXPR's RENDERED value in a temp buffer and return it, live."
|
||||
(let ((flan-inspect-request-function
|
||||
(lambda (_) (list :status "ok" :value rendered)))
|
||||
(flan-inspect-buffer " *test-inspect*"))
|
||||
(when (get-buffer " *test-inspect*") (kill-buffer " *test-inspect*"))
|
||||
(save-window-excursion (flan-inspect--show expr nil))))
|
||||
|
||||
(let* ((buf (test-flan--inspect
|
||||
"b" "(Blob {:id 7 :name \"sandy\" :pos (V {:x 1.5 :y 0})})"))
|
||||
(text (with-current-buffer buf (buffer-string))))
|
||||
(test-flan--check "the expression is at the top" (string-match-p "\\`b\n" text))
|
||||
(test-flan--check "and the type under it" (string-match-p "a Blob" text))
|
||||
(test-flan--check "the fields are listed" (string-match-p ":id.*7" text))
|
||||
(test-flan--check "a nested struct is summarised, not expanded"
|
||||
(string-match-p ":pos +(V … 2 fields)" text))
|
||||
(test-flan--check "and the keys are shown" (string-match-p "RET inspect" text))
|
||||
;; Every field line carries the step that reaches it.
|
||||
(with-current-buffer buf
|
||||
(goto-char (point-min))
|
||||
(flan-inspect-next)
|
||||
(test-flan--check "TAB lands on the first field"
|
||||
(equal (get-text-property (point) 'flan-inspect-step)
|
||||
'(:field "id")))
|
||||
(flan-inspect-next)
|
||||
(flan-inspect-next)
|
||||
(test-flan--check "and walks to the third"
|
||||
(equal (get-text-property (point) 'flan-inspect-step)
|
||||
'(:field "pos")))
|
||||
;; Backwards is the same list walked the other way. It is tested because
|
||||
;; an asymmetry here is the kind of thing nobody reports and everybody
|
||||
;; notices — and because point lands mid-line after a search, where a
|
||||
;; property-change walk and a field walk disagree.
|
||||
(flan-inspect-previous)
|
||||
(test-flan--check "p comes back to the second"
|
||||
(equal (get-text-property (point) 'flan-inspect-step)
|
||||
'(:field "name")))
|
||||
;; From the middle of a line, `p' goes to the start of the field point is
|
||||
;; *in*, which is CIDER's behaviour and the reason both commands go
|
||||
;; through one list of field starts: walking property changes from
|
||||
;; mid-line finds the end of the current field instead, and forward and
|
||||
;; backward then disagree about where a field begins.
|
||||
(end-of-line)
|
||||
(flan-inspect-previous)
|
||||
(test-flan--check "from mid-line, p reaches this field's start"
|
||||
(equal (get-text-property (point) 'flan-inspect-step)
|
||||
'(:field "name")))
|
||||
(flan-inspect-previous)
|
||||
(test-flan--check "and then the one before it"
|
||||
(equal (get-text-property (point) 'flan-inspect-step)
|
||||
'(:field "id")))
|
||||
(flan-inspect-previous)
|
||||
(test-flan--check "p wraps to the last, as n wraps to the first"
|
||||
(equal (get-text-property (point) 'flan-inspect-step)
|
||||
'(:field "pos")))
|
||||
(flan-inspect-next)
|
||||
(test-flan--check "and n wraps round from it"
|
||||
(equal (get-text-property (point) 'flan-inspect-step)
|
||||
'(:field "id")))))
|
||||
|
||||
;; Going in sends a *different expression*, which is the entire adaptation.
|
||||
(let ((asked nil))
|
||||
(let ((flan-inspect-request-function
|
||||
(lambda (form)
|
||||
(push (plist-get form :code) asked)
|
||||
(list :status "ok"
|
||||
:value (if (equal (plist-get form :code) "(.pos b)")
|
||||
"(V {:x 1.5 :y 0})"
|
||||
"(Blob {:id 7 :pos (V {:x 1.5 :y 0})})"))))
|
||||
(flan-inspect-buffer " *test-inspect*"))
|
||||
(when (get-buffer " *test-inspect*") (kill-buffer " *test-inspect*"))
|
||||
(save-window-excursion
|
||||
(flan-inspect--show "b" nil)
|
||||
(with-current-buffer " *test-inspect*"
|
||||
(goto-char (point-min))
|
||||
(flan-inspect-next) (flan-inspect-next) ; :pos
|
||||
(flan-inspect-into)
|
||||
(test-flan--check "going in asks for the accessor expression"
|
||||
(equal (car asked) "(.pos b)"))
|
||||
(test-flan--check "and the buffer is now showing that"
|
||||
(string-match-p "\\`(\\.pos b)\n" (buffer-string)))
|
||||
(test-flan--check "with the stack behind it"
|
||||
(string-match-p "via b > here" (buffer-string)))
|
||||
(flan-inspect-pop)
|
||||
(test-flan--check "coming back asks for the one we came from"
|
||||
(equal (car asked) "b"))
|
||||
(test-flan--check "and there is no stack left"
|
||||
(not (string-match-p "via" (buffer-string))))
|
||||
(test-flan--check "popping at the root refuses"
|
||||
(string-match-p
|
||||
"nothing behind it"
|
||||
(or (test-flan--caught #'flan-inspect-pop) "")))))))
|
||||
|
||||
;; RET on something that cannot be entered refuses there, rather than sending
|
||||
;; an expression the program would reject.
|
||||
(let* ((buf (test-flan--inspect "p" "(Node {:next <ptr> :n 1})")))
|
||||
(with-current-buffer buf
|
||||
(goto-char (point-min))
|
||||
(flan-inspect-next)
|
||||
(test-flan--check "RET on a pointer field refuses, naming it"
|
||||
(string-match-p "pointer"
|
||||
(or (test-flan--caught #'flan-inspect-into) "")))))
|
||||
|
||||
;; An atom root has nothing to go into, and the buffer says so rather than
|
||||
;; drawing an empty field list.
|
||||
(let ((text (with-current-buffer (test-flan--inspect "(.x p)" "1.5") (buffer-string))))
|
||||
(test-flan--check "an atom root explains itself"
|
||||
(string-match-p "Nothing to go into:.*atom" text)))
|
||||
|
||||
;; The span bound is drawn, because a field list that silently stops is a lie
|
||||
;; about the value.
|
||||
(let ((text (with-current-buffer
|
||||
(test-flan--inspect "w" "(Wide {:a 1 :b 2 ...})") (buffer-string))))
|
||||
(test-flan--check "span truncation is drawn, not dropped"
|
||||
(string-match-p "span bound of 8" text)))
|
||||
|
||||
|
||||
|
||||
|
||||
;;; Restarts: which of them can be taken
|
||||
|
||||
(message "\nrestarts, and §4's shadowing")
|
||||
|
||||
(let ((rows (flan-cnr-annotate-restarts '("retry" "use-placeholder" "retry" "skip"))))
|
||||
(test-flan--check "numbered from zero, innermost first"
|
||||
(equal (mapcar (lambda (r) (nth 0 r)) rows) '(0 1 2 3)))
|
||||
(test-flan--check "the first of a name owns it"
|
||||
(null (nth 2 (nth 0 rows))))
|
||||
(test-flan--check "a repeat is shadowed by it"
|
||||
(equal (nth 2 (nth 2 rows)) 0))
|
||||
(test-flan--check "and a different name is not"
|
||||
(null (nth 2 (nth 3 rows)))))
|
||||
|
||||
(test-flan--check "no restarts is a list of no rows"
|
||||
(null (flan-cnr-annotate-restarts nil)))
|
||||
|
||||
|
||||
;;; The break buffer
|
||||
|
||||
(message "\nthe break buffer")
|
||||
|
||||
(defun test-flan--cnr (state)
|
||||
"Draw STATE and return the buffer."
|
||||
(let ((buf (get-buffer-create " *test-cnr*")))
|
||||
(with-current-buffer buf
|
||||
(let ((inhibit-read-only t)) (erase-buffer))
|
||||
(flan-cnr-mode)
|
||||
(setq flan-cnr--open nil)
|
||||
(flan-cnr--render state))
|
||||
buf))
|
||||
|
||||
;; What the daemon can answer today, and nothing more: a class name and a list
|
||||
;; of names.
|
||||
(let* ((buf (test-flan--cnr
|
||||
(list :condition "Missing"
|
||||
:restarts '("retry" "use-placeholder" "retry"))))
|
||||
(text (with-current-buffer buf (buffer-string))))
|
||||
;; SBCL's order, which is the claim this buffer is making.
|
||||
(test-flan--check "the condition is first"
|
||||
(string-match-p "\\`Missing" text))
|
||||
(test-flan--check "the restarts are before the stack"
|
||||
(< (string-match "Restarts" text) (string-match "Stack" text)))
|
||||
(test-flan--check "restarts are numbered"
|
||||
(string-match-p " 0: \\[retry\\]" text))
|
||||
(test-flan--check "a shadowed one has no bracket, as SBCL's has none"
|
||||
(string-match-p " 2: retry " text))
|
||||
(test-flan--check "and says why, and what it would take"
|
||||
(string-match-p "shadowed by 0.*restart-at" text))
|
||||
(test-flan--check "abort is the last entry on the same list"
|
||||
(string-match-p " 3: \\[abort\\]" text))
|
||||
;; The rule: nothing implemented is refused by name, with the reason. These
|
||||
;; three sections exist and are empty, and each says what would fill it.
|
||||
;; The shape of a condition and the values in it are two different
|
||||
;; refusals, and with nothing at all the outer one is what shows.
|
||||
(test-flan--check "the condition's fields are refused, not omitted"
|
||||
(string-match-p "Condition fields:\n not available.*Tast.structs" text))
|
||||
(test-flan--check "the stack is refused, naming DWARF"
|
||||
(string-match-p "Stack.*\n not available.*DWARF"
|
||||
(substring text (string-match "--- Stack" text))))
|
||||
(test-flan--check "and the keys are shown" (string-match-p "TAB fold a frame" text)))
|
||||
|
||||
;; A stopped program with nothing on offer between the error and the top. It
|
||||
;; is a real state — spec-conditions §2's `error' with no `restart-case' above
|
||||
;; it — and it must not look like a bug in the buffer.
|
||||
(let ((text (with-current-buffer
|
||||
(test-flan--cnr (list :condition "Missing" :restarts nil))
|
||||
(buffer-string))))
|
||||
(test-flan--check "no restarts is said, not drawn blank"
|
||||
(string-match-p "none are active" text))
|
||||
(test-flan--check "and abort is still offered"
|
||||
(string-match-p " 0: \\[abort\\]" text)))
|
||||
|
||||
;; Taking one sends `restart' with the name.
|
||||
(let ((sent nil))
|
||||
(let ((flan-cnr-request-function
|
||||
(lambda (form) (setq sent form) (list :status "ok" :note "accepted"))))
|
||||
(with-current-buffer (test-flan--cnr
|
||||
(list :condition "Missing" :restarts '("retry" "skip")))
|
||||
(goto-char (point-min))
|
||||
(search-forward " 1: ")
|
||||
(save-window-excursion (flan-cnr-take))
|
||||
(test-flan--check "RET on a restart sends its name"
|
||||
(equal sent '(:op "restart" :name "skip"))))))
|
||||
|
||||
;; And a shadowed one is refused here rather than sent, which is the bug in
|
||||
;; today's `completing-read': it would send "retry" and the *inner* frame would
|
||||
;; take it, silently.
|
||||
(let ((sent nil))
|
||||
(let ((flan-cnr-request-function (lambda (form) (setq sent form) '(:status "ok"))))
|
||||
(with-current-buffer (test-flan--cnr
|
||||
(list :condition "Missing" :restarts '("retry" "a" "retry")))
|
||||
(goto-char (point-min))
|
||||
(search-forward " 2: ")
|
||||
(let ((err (test-flan--caught #'flan-cnr-take)))
|
||||
(test-flan--check "a shadowed restart refuses"
|
||||
(and err (string-match-p "shadowed by 0" err)))
|
||||
(test-flan--check "and nothing was sent" (null sent))))))
|
||||
|
||||
;; A digit takes one, as it does in SBCL.
|
||||
(let ((sent nil))
|
||||
(let ((flan-cnr-request-function
|
||||
(lambda (form) (setq sent form) (list :status "ok" :note "accepted"))))
|
||||
(with-current-buffer (test-flan--cnr
|
||||
(list :condition "Missing" :restarts '("retry" "skip")))
|
||||
(goto-char (point-max))
|
||||
(let ((last-command-event ?0))
|
||||
(save-window-excursion (call-interactively #'flan-cnr-take-number)))
|
||||
(test-flan--check "0 takes the innermost"
|
||||
(equal sent '(:op "restart" :name "retry")))
|
||||
(let ((last-command-event ?2))
|
||||
(save-window-excursion (call-interactively #'flan-cnr-take-number)))
|
||||
(test-flan--check "and the number past the last is abort"
|
||||
(equal sent '(:op "abort"))))))
|
||||
|
||||
;; The stack and its locals. Nothing produces this data today; the fixture is
|
||||
;; the shape a `backtrace' verb would have to answer with, and building the
|
||||
;; buffer against it is how it is ready when one exists.
|
||||
(let* ((state (list :condition "Missing"
|
||||
:restarts '("retry")
|
||||
:stack (list (list :fn "sim/settle" :loc "sand.flan:42:3"
|
||||
:locals '(("i" "i32" "7")
|
||||
("b" "Blob" "(Blob {:id 7})")))
|
||||
(list :fn "sim/step" :loc "sand.flan:60:1"
|
||||
:locals nil))))
|
||||
(buf (test-flan--cnr state))
|
||||
(text (with-current-buffer buf (buffer-string))))
|
||||
(test-flan--check "frames are numbered, innermost first"
|
||||
(string-match-p " 0: > sim/settle" text))
|
||||
(test-flan--check "with where they are" (string-match-p "sand.flan:42:3" text))
|
||||
(test-flan--check "locals are collapsed to begin with"
|
||||
(not (string-match-p "i32 i = 7" text)))
|
||||
(with-current-buffer buf
|
||||
(goto-char (point-min))
|
||||
(search-forward " 0: > sim/settle")
|
||||
(flan-cnr-toggle-frame)
|
||||
(test-flan--check "TAB on a frame opens its locals"
|
||||
(string-match-p "i32 i = 7" (buffer-string)))
|
||||
(test-flan--check "and the marker turns"
|
||||
(string-match-p " 0: v sim/settle" (buffer-string)))
|
||||
;; A frame whose locals nobody could read says so, in the same place the
|
||||
;; locals would have been.
|
||||
(goto-char (point-min))
|
||||
(search-forward " 1: > sim/step")
|
||||
(flan-cnr-toggle-frame)
|
||||
(test-flan--check "a frame with no locals refuses, naming DWARF"
|
||||
(string-match-p "not available.*DWARF" (buffer-string)))
|
||||
(goto-char (point-min))
|
||||
(search-forward " 0: v sim/settle")
|
||||
(flan-cnr-toggle-frame)
|
||||
(test-flan--check "and TAB again closes it"
|
||||
(not (string-match-p "i32 i = 7" (buffer-string))))))
|
||||
|
||||
;; The two buffers meet: `i' on a local opens the inspector on its name, which
|
||||
;; is an expression the program can be handed.
|
||||
(let ((asked nil))
|
||||
(let ((flan-inspect-request-function
|
||||
(lambda (form) (push (plist-get form :code) asked)
|
||||
(list :status "ok" :value "(Blob {:id 7})")))
|
||||
(flan-inspect-buffer " *test-inspect*"))
|
||||
(with-current-buffer (test-flan--cnr
|
||||
(list :condition "Missing" :restarts '("retry")
|
||||
:stack (list (list :fn "f" :locals '(("b" "Blob" "…"))))))
|
||||
(goto-char (point-min))
|
||||
(search-forward " 0: > f")
|
||||
(flan-cnr-toggle-frame)
|
||||
(goto-char (point-min))
|
||||
(search-forward "Blob b")
|
||||
(save-window-excursion (flan-cnr-inspect))
|
||||
(test-flan--check "`i' on a local inspects it by name"
|
||||
(equal (car asked) "b")))))
|
||||
|
||||
;; `flan-cnr-show' refuses a running program by name rather than opening an
|
||||
;; empty buffer.
|
||||
;; The layout without the values: what a `layout' op alone would buy. The
|
||||
;; names and the types come out of Tast.structs, which the daemon holds
|
||||
;; whether or not a program is running; only the values need the pointer the
|
||||
;; break loop was handed. Drawing the two apart is strictly more than saying
|
||||
;; nothing, and it is what tells you whether the field you were about to
|
||||
;; blame is even a field of this condition.
|
||||
(let ((text (with-current-buffer
|
||||
(test-flan--cnr (list :condition "Missing" :restarts '("retry")
|
||||
:fields '(("path" "string" nil)
|
||||
("tried" "i32" "3"))))
|
||||
(buffer-string))))
|
||||
(test-flan--check "a field is named and typed even with no value"
|
||||
(string-match-p ":path *string *value not available" text))
|
||||
(test-flan--check "and the missing value names the verb it needs"
|
||||
(string-match-p "value not available.*agent verb: `condition'" text))
|
||||
(test-flan--check "a value that is there is simply shown"
|
||||
(string-match-p ":tried *i32 *3" text)))
|
||||
|
||||
;; Backwards through the buffer, for the same reason as in the inspector.
|
||||
(with-current-buffer (test-flan--cnr
|
||||
(list :condition "Missing" :restarts '("retry" "skip")))
|
||||
(goto-char (point-min))
|
||||
(search-forward "[abort]")
|
||||
(beginning-of-line)
|
||||
(flan-cnr-previous)
|
||||
(test-flan--check "p from abort lands on the last restart"
|
||||
(equal (get-text-property (point) 'flan-cnr-index) 1))
|
||||
(flan-cnr-next)
|
||||
(test-flan--check "and n goes back to abort"
|
||||
(get-text-property (point) 'flan-cnr-abort)))
|
||||
|
||||
(let ((flan-cnr-request-function
|
||||
(lambda (_) '(:status "ok" :restarts nil :stopped nil))))
|
||||
(test-flan--check "a running program is refused, by name"
|
||||
(string-match-p "no restart stack"
|
||||
(or (test-flan--caught #'flan-cnr-show) ""))))
|
||||
|
||||
(let ((flan-cnr-request-function
|
||||
(lambda (_) '(:status "error" :message "the program exited"))))
|
||||
(test-flan--check "and the daemon's own refusal is passed through"
|
||||
(string-match-p "the program exited"
|
||||
(or (test-flan--caught #'flan-cnr-show) ""))))
|
||||
|
||||
|
||||
(message "\n%d checks, %d failures" test-flan--ran test-flan--failures)
|
||||
(kill-emacs (if (> test-flan--failures 0) 1 0))
|
||||
|
||||
;;; test-flan-cider.el ends here
|
||||
@ -1,5 +1,5 @@
|
||||
(tests
|
||||
(names test_flan test_acceptance test_reload test_agent test_session test_dev test_emacs test_repl)
|
||||
(names test_flan test_acceptance test_reload test_agent test_session test_dev test_emacs test_repl test_cider)
|
||||
(libraries flan unix)
|
||||
; The acceptance programs are part of the test corpus: if the reader, the
|
||||
; parser or the checker regresses on them we want to know here, not at the CLI.
|
||||
|
||||
27
test/test_cider.ml
Normal file
27
test/test_cider.ml
Normal file
@ -0,0 +1,27 @@
|
||||
(* The inspector and the break buffer, driven from fixtures.
|
||||
|
||||
Unlike test_emacs.ml there is no daemon and no running program behind this,
|
||||
and that is the point rather than a shortcut. Both buffers are functions
|
||||
from a reply's data to text with properties on it, and every interesting way
|
||||
they can be wrong is on that side: a struct the reader mis-parses, a
|
||||
shadowed restart drawn as though it could be taken, a section quietly
|
||||
omitted where it should have been refused. Fixtures also reach the states a
|
||||
live program is hard to hold still in — a value past the renderer's depth
|
||||
bound, two restarts sharing a name, a frame with locals in it at all.
|
||||
|
||||
Skipped, not failed, where there is no emacs: the compiler does not depend
|
||||
on one. *)
|
||||
|
||||
let () =
|
||||
if Sys.command "command -v emacs > /dev/null 2>&1" <> 0 then
|
||||
print_endline "cider: skipped (no emacs on PATH)"
|
||||
else
|
||||
let code =
|
||||
Sys.command
|
||||
"emacs -Q --batch -L ../../../emacs -l ../../../emacs/test-flan-cider.el 2>&1"
|
||||
in
|
||||
if code = 0 then print_endline "cider: all tests passed"
|
||||
else begin
|
||||
Printf.printf "\nthe inspector/break buffer tests exited %d\n" code;
|
||||
exit 1
|
||||
end
|
||||
Loading…
x
Reference in New Issue
Block a user