diff --git a/emacs/flan-cnr.el b/emacs/flan-cnr.el index 749f931..dd3e319 100644 --- a/emacs/flan-cnr.el +++ b/emacs/flan-cnr.el @@ -38,14 +38,14 @@ ;; ;; `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. +;; A restart *typed by name* resolves to the innermost frame offering it, so a +;; second frame offering `retry' is real, is on the list, and cannot be named +;; from a prompt — spec-conditions.md §4, and `flan_find_restart' in the +;; runtime. Today's `completing-read' hides it: the list has `retry' twice, +;; picking either sends the string "retry", and the inner one runs. Here +;; every choice goes out by *number* (`restart-at', with the name as a +;; receipt), so a shadowed entry is drawn without its bracket and is still +;; takeable — the bracket says only what a typed name would reach. ;; ;; **CIDER's stacktrace buffer** answers *how it should behave*: frames that ;; expand in place, TAB to fold, everything reachable from the keyboard, @@ -84,25 +84,19 @@ from fixtures, and so `flan.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. +;; Said in one table rather than at each use, so a section's reason is +;; revisable in one place. One short sentence each: these print in the +;; buffer, and the buffer is not the place for design notes. (defconst flan-cnr-unavailable '((layout - . "the daemon could not resolve this condition's name to a struct [the `layout' op answers out of `Tast.structs' and needs a *qualified* name. A package qualifies what it declares, so two packages' `Missing' are two names and neither is `Missing'; the daemon refuses a bare one and lists what it could have meant rather than picking. A name it cannot place at all is a program built from source this daemon did not compile]") - (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]") + . "no struct has this name; a trap's name has no fields behind it") (stack - . "the program is running. A backtrace is the game thread's frame chain and it is changing while it runs, so the daemon refuses to take one [not a missing feature: ask again once it has stopped]") + . "the program is running; ask again once it stops") (locals - . "this frame has no named locals the daemon can read. A slot the compiler invented is refused by name rather than shown as `s4', and a slot whose binding had not run when the error happened has no address yet [both are refusals with reasons, not gaps — the frame's own line says how many slots it has]") + . "this frame has no named locals") (globals - . "no frame on this stack references a global [not a gap: the section is the *union of what the frames reach*, not a listing of everything the program has, so an empty one means the state this stack is working on is all in its locals]")) + . "no frame on this stack reads a global; its state is all in its locals")) "Why a section of this buffer is empty, by name.") (defun flan-cnr--why (key) @@ -149,6 +143,41 @@ nothing in the compiler knows a breakpoint from an error and this buffer is the first place that can tell the difference. Named here rather than spelled at its use, because it is a fact about the prelude.") +(defun flan-cnr--headline-fields (fields) + "The condition's own numbers, folded into the headline. +FIELDS is the fields list; the result is \"low 9, high 9, length 4\" over the +fields whose values arrived and are short enough to read inline, or nil. +Generic on purpose: the fields are the condition's own, so BoundsError reads +as its numbers and every other condition reads as its own." + (let ((short (seq-filter (lambda (f) + (and (nth 2 f) (<= (length (nth 2 f)) 24) + (not (string-match-p "\n" (nth 2 f))))) + fields))) + (when short + (mapconcat (lambda (f) (format "%s %s" (nth 0 f) (nth 2 f))) + (seq-take short 4) ", ")))) + +(defun flan-cnr--site-line-col (site) + "The (LINE . COL) a SITE string names, or nil." + (when (and site (string-match ":\\([0-9]+\\):\\([0-9]+\\)\\'" site)) + (cons (string-to-number (match-string 1 site)) + (string-to-number (match-string 2 site))))) + +(defun flan-cnr--insert-site (state) + "Where the expression that trapped is written, with the line and a caret. +The frame lines below say where each call was; this is the only record of the +indexing or the division itself, so it sits directly under the headline." + (let ((site (plist-get state :site))) + (when site + (insert (propertize (format "at %s\n" site) 'face 'shadow)) + (let ((source (plist-get state :source)) + (lc (flan-cnr--site-line-col site))) + (when (and source lc) + (let ((prefix (format "%4d| " (car lc)))) + (insert "\n" (propertize prefix 'face 'shadow) source "\n") + (insert (make-string (+ (length prefix) (max 0 (1- (cdr lc)))) ?\s) + (propertize "^" 'face 'error) "\n"))))))) + (defun flan-cnr--insert-condition (state) (let* ((name (or (plist-get state :condition) "a condition")) ;; A breakpoint is a stop, not a failure. Everything underneath is @@ -157,26 +186,30 @@ its use, because it is a fact about the prelude.") ;; only thing that can be wrong here is the word for it. Calling a ;; breakpoint unhandled would be a small lie told at the top of the ;; one buffer that exists to say what happened. - (paused (equal name flan-cnr-breakpoint))) + (paused (equal name flan-cnr-breakpoint)) + (numbers (flan-cnr--headline-fields (plist-get state :fields)))) (insert (propertize name 'face (if paused 'warning 'error))) + (when numbers (insert " — " numbers)) + (insert "\n") (insert (propertize (if paused - " — a breakpoint; stopped where (pause) was called, nothing unwound\n" - " — unhandled; stopped on the frame that erred, nothing unwound\n") - 'face 'shadow))) + "stopped at (pause); nothing has been unwound\n" + "unhandled; stopped where it erred, nothing unwound\n") + 'face 'shadow)) + (flan-cnr--insert-site state)) (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))) + ;; The shape and the values are two answers. The shape — names and types — + ;; is the daemon's own, out of the build it holds; the values are read out + ;; of the stopped program by a thunk the daemon builds. So a field can be + ;; named and typed while its value is missing, and the row says why in one + ;; sentence rather than being left off. + (let ((fields (plist-get state :fields)) + (why (plist-get state :fields-why))) (if (null fields) - (insert (flan-cnr--unavailable 'layout)) + (insert (propertize (concat " not available — " + (or why (flan-cnr--why 'layout)) "\n") + 'face 'font-lock-comment-face)) (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) @@ -187,9 +220,10 @@ its use, because it is a fact about the prelude.") (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)) + (propertize + (concat "not read — " + (or (nth 3 f) why "the stop's value was not readable")) + 'face 'font-lock-comment-face)) "\n") (add-text-properties start (point) (list 'flan-cnr-inspect nil @@ -209,21 +243,23 @@ its use, because it is a fact about the prelude.") (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. + ;; gone when it does not. A shadowed entry is still takeable — the + ;; choice goes out by number, not by name — so the missing bracket + ;; says only that typing the name at a prompt would reach the + ;; inner one. (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))) + (when owner + (insert (propertize + (format "same name as %d; taken by its number" owner) + 'face 'shadow))) (insert "\n") (add-text-properties start (point) - (list 'flan-cnr-restart (if owner nil name) + (list 'flan-cnr-restart name 'flan-cnr-shadowed owner 'flan-cnr-index i 'mouse-face 'highlight)))))) @@ -232,7 +268,7 @@ its use, because it is a fact about the prelude.") (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" + (insert (propertize "end the program here; the dev session ends with it\n" 'face 'shadow)) (add-text-properties start (point) (list 'flan-cnr-abort t 'mouse-face 'highlight)))) @@ -375,25 +411,26 @@ puts the likely culprit on top." ;;; 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))) + (flan-cnr--invoke (get-text-property (point) 'flan-cnr-index) + (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)))) +(defun flan-cnr--invoke (index name) + "Take restart INDEX, named NAME. +By index, because the index is the identity — two frames can offer `retry' +and only one of them is the one on this line. The name rides along as a +receipt: the daemon checks it against what the program has at that index and +refuses if the two have drifted apart, so a stale buffer cannot take a +different restart than the one it showed." + (let ((r (funcall flan-cnr-request-function + (list :op "restart-at" :index index :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 @@ -555,9 +592,10 @@ anyone who would rather TAB always moved." (defun flan-cnr-state-from-reply (reply &optional fields stack globals) "The buffer's state, out of a `break' REPLY. -FIELDS is the condition's layout, if it was asked for and answered — a list of -(NAME TYPE VALUE), where VALUE is nil because no running program was consulted -to get it. +FIELDS is what `flan-cnr-condition-fields' returned — rows of +(NAME TYPE VALUE), with VALUE nil where it could not be read, and the +one-sentence reason beside them — or the bare rows, which is how the +fixture-driven tests pass them. GLOBALS is what `flan-cnr-globals' returned, or nil. @@ -569,7 +607,18 @@ Takes the layout rather than fetching it, so this stays a function from data to data and the fixture-driven tests can drive it without a socket." (list :condition (plist-get reply :condition) :restarts (plist-get reply :restarts) - :fields fields + ;; Where the expression that trapped is written, and that line's text. + ;; `break' carries both when the stop has a site; a user (error ...) + ;; has none, and then the headline simply has no line to point at. + :site (plist-get reply :site) + :source (plist-get reply :source) + ;; FIELDS is either the rows themselves — the fixtures' shape — or + ;; `flan-cnr-condition-fields''s plist of rows plus the one-sentence + ;; reason the values half is missing. + :fields (if (keywordp (car-safe fields)) + (plist-get fields :fields) + fields) + :fields-why (and (keywordp (car-safe fields)) (plist-get fields :why)) ;; STACK is passed in rather than fetched, for the same reason FIELDS ;; is: this stays a function from data to data, so the fixture tests ;; drive it with no socket. Nil is still a legitimate answer — the @@ -602,13 +651,43 @@ it is empty, which is the degradation the buffer is already built for." (let ((r (funcall flan-cnr-request-function (list :op "layout" :type type)))) (when (equal (plist-get r :status) "ok") (mapcar (lambda (f) - ;; The value is nil, and that is the honest half: the shape - ;; of a condition is a fact about the build, its contents - ;; are a fact about the stopped frame, and only the first is - ;; knowable today. + ;; The value is nil: the shape of a condition is a fact + ;; about the build, its contents are a fact about the + ;; stopped frame, and this op only ever answers the first. (list (nth 0 f) (nth 1 f) nil)) (plist-get r :fields)))))) +(defun flan-cnr-condition-fields (type) + "The stopped condition's fields with their values, or what stands in. +Asks `condition' first — the daemon builds a thunk that renders the fields at +the pointer the break loop stashed — and falls back to `layout' when that is +refused, so the names and the types still show with one sentence saying why +the values do not. Returns (:fields ROWS :why WHY): ROWS are +(NAME TYPE VALUE [WHY]) with VALUE nil where it was not read, and WHY is the +section-wide reason, nil when the values arrived." + (let ((r (funcall flan-cnr-request-function '(:op "condition")))) + (if (equal (plist-get r :status) "ok") + (list :fields + (append + (mapcar (lambda (f) (list (nth 0 f) (nth 1 f) (nth 2 f))) + (plist-get r :fields)) + ;; A field the renderer refused — no printer for its type — + ;; still shows, with its own reason in the value column. + (mapcar (lambda (f) (list (nth 0 f) nil nil (nth 1 f))) + (plist-get r :refused))) + :why nil) + (let* ((why (plist-get r :message)) + (r2 (when (and type (not (string-empty-p type))) + (funcall flan-cnr-request-function + (list :op "layout" :type type)))) + (ok2 (equal (plist-get r2 :status) "ok")) + (layout (when ok2 + (mapcar (lambda (f) (list (nth 0 f) (nth 1 f) nil)) + (plist-get r2 :fields))))) + (list :fields layout + :why (or why (unless ok2 (plist-get r2 :message)) + (and layout "the stop's value was not readable"))))))) + (defun flan-cnr-backtrace () "The stopped program's frames, innermost first, as the renderer wants them. @@ -690,7 +769,8 @@ walk from a running program." (unless (derived-mode-p 'flan-cnr-mode) (flan-cnr-mode)) (flan-cnr--render (flan-cnr-state-from-reply r - (flan-cnr-layout (plist-get r :condition)) + (flan-cnr-condition-fields + (plist-get r :condition)) (flan-cnr-backtrace) (flan-cnr-globals)))) (pop-to-buffer buf) diff --git a/emacs/test-flan-cider.el b/emacs/test-flan-cider.el index 0e613c7..1e489fc 100644 --- a/emacs/test-flan-cider.el +++ b/emacs/test-flan-cider.el @@ -981,8 +981,8 @@ would be overwritten. Look again and re-do the edit") (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 "and says whose name it repeats" + (string-match-p "same name as 0" 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 @@ -990,7 +990,7 @@ would be overwritten. Look again and re-do the edit") ;; 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)) + (string-match-p "Condition fields:\n not available — no struct" text)) ;; The stack is no longer refused for want of a mechanism — the shadow stack ;; landed and the daemon answers `backtrace'. What this fixture has is no ;; stack *passed in*, which is the running-program case, so the reason it @@ -1011,7 +1011,9 @@ would be overwritten. Look again and re-do the edit") (test-flan--check "and abort is still offered" (string-match-p " 0: \\[abort\\]" text))) -;; Taking one sends `restart' with the name. +;; Taking one sends `restart-at' with the index, and the name as a receipt: +;; the index is the identity — two frames can offer `retry' — and the name is +;; what lets the daemon refuse a buffer that has gone stale. (let ((sent nil)) (let ((flan-cnr-request-function (lambda (form) (setq sent form) (list :status "ok" :note "accepted")))) @@ -1020,22 +1022,23 @@ would be overwritten. Look again and re-do the edit") (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")))))) + (test-flan--check "RET on a restart sends its index, name as receipt" + (equal sent '(:op "restart-at" :index 1 :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. +;; And a shadowed one is *takeable* now — the choice goes out by number, so +;; the inner frame owning the name no longer matters. This is the bug +;; `completing-read' had: it sent "retry" and the inner frame took it, +;; silently. (let ((sent nil)) - (let ((flan-cnr-request-function (lambda (form) (setq sent form) '(:status "ok")))) + (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" "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)))))) + (save-window-excursion (flan-cnr-take)) + (test-flan--check "a shadowed restart is taken by its own index" + (equal sent '(:op "restart-at" :index 2 :name "retry")))))) ;; A digit takes one, as it does in SBCL. (let ((sent nil)) @@ -1047,7 +1050,7 @@ would be overwritten. Look again and re-do the edit") (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"))) + (equal sent '(:op "restart-at" :index 0 :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" @@ -1150,11 +1153,51 @@ would be overwritten. Look again and re-do the edit") ("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)) + (string-match-p ":path *string *not read" text)) + (test-flan--check "and the missing value gets one short sentence" + (string-match-p "not read — [^[]*\n" text)) (test-flan--check "a value that is there is simply shown" - (string-match-p ":tried *i32 *3" text))) + (string-match-p ":tried *i32 *3" text)) + ;; The headline reads the condition's own numbers, so what happened is the + ;; first line rather than something assembled from the fields below. + (test-flan--check "the headline carries the fields that have values" + (string-match-p "\\`Missing — tried 3" text))) + +;; The whole point of the `condition' verb: values beside the shape, read out +;; of the stopped program by a thunk the daemon builds, with nothing +;; special-casing any one condition type. +(let ((text (with-current-buffer + (test-flan--cnr + (list :condition "BoundsError" + :restarts '("continue") + :fields '(("low" "i64" "648") ("high" "i64" "648") + ("length" "i64" "100")) + :site "/home/x/sand.flan:52:13" + :source " (set (at grid i) 1)")) + (buffer-string)))) + (test-flan--check "the headline is the condition's own numbers" + (string-match-p "\\`BoundsError — low 648, high 648, length 100" + text)) + (test-flan--check "the site is under the headline" + (string-match-p "at /home/x/sand.flan:52:13" text)) + (test-flan--check "with the source line" + (string-match-p " 52| +(set (at grid i) 1)" text)) + (test-flan--check "and a caret under the column" + (string-match-p "\n +\\^\n" text)) + (test-flan--check "every field renders with its value" + (string-match-p ":length +i64 +100" text))) + +;; No implementation note ever prints: the bracketed design asides used to +;; leak into the buffer, and the fix is pinned as a property of the whole +;; rendering rather than of one string. +(let ((text (with-current-buffer + (test-flan--cnr + (list :condition "Missing" :restarts '("retry" "a" "retry") + :fields '(("path" "string" nil)) + :stack (list (list :fn "f" :fetched t :locals nil)))) + (buffer-string)))) + (test-flan--check "no bracketed implementation note leaks into the buffer" + (not (string-match-p "\\[needs\\|agent verb\\|Tast\\." text)))) ;; Backwards through the buffer, for the same reason as in the inspector. (with-current-buffer (test-flan--cnr @@ -1202,10 +1245,11 @@ would be overwritten. Look again and re-do the edit") "sim/Missing")) (test-flan--check "the fields are drawn, named and typed" (string-match-p ":path *string" text)) - ;; Shape and contents are two different questions, and only the first is - ;; answerable without the pointer the break loop discards. + ;; Shape and contents are two different questions, and this stub's + ;; daemon answers only the first — so the values fall back to the + ;; layout, each row saying in one sentence why it is empty. (test-flan--check "and every value still says why it is missing" - (string-match-p ":tried *i32 *value not available" text))))) + (string-match-p ":tried *i32 *not read" text))))) ;; A layout the daemon refuses — a bare name it will not guess between two ;; packages, or a type it cannot place — leaves the section drawing its reason @@ -1221,7 +1265,7 @@ would be overwritten. Look again and re-do the edit") (let ((text (with-current-buffer (save-window-excursion (flan-cnr-show)) (buffer-string)))) (test-flan--check "a refused layout is a section that says so" - (string-match-p "not available.*needs a \\*qualified\\* name" text)) + (string-match-p "not available — .*not a qualified name" text)) (test-flan--check "and the restarts are drawn anyway" (string-match-p "\\[retry\\]" text)))) @@ -1269,8 +1313,7 @@ would be overwritten. Look again and re-do the edit") :stack (list (list :fn "f")))) (buffer-string)))) (test-flan--check "an empty globals section says what empty means" - (string-match-p "not available.*union of what the frames reach" - text))) + (string-match-p "not available.*all in its locals" text))) ;; A frame the daemon could not attribute makes the union smaller than the real ;; one, and a list that is short without saying so is the failure this whole @@ -1384,7 +1427,7 @@ stopped program, which is the case where it should fire." (lambda () (flan-cnr--insert-condition (list :condition flan-cnr-breakpoint)))))) (test-flan--check "a breakpoint is called a breakpoint" - (string-match-p "a breakpoint; stopped where (pause)" text)) + (string-match-p "stopped at (pause)" text)) (test-flan--check "and is not called unhandled" (not (string-match-p "unhandled" text))))