diff --git a/emacs/flan.el b/emacs/flan.el index c0fab618..3f65d6a3 100644 --- a/emacs/flan.el +++ b/emacs/flan.el @@ -1847,6 +1847,62 @@ Returns non-nil when it put an overlay somewhere." (goto-char beg)) t))))))) +;;; Warnings + +;; A warning is drawn the way an error is — a mark at the site, the message +;; beside it, gone at the next command — and logged the same way, in the +;; compiler's own `file:line:col: warning: text' shape, which is what gives it +;; `compilation-minor-mode''s warning face in the log. The marks carry +;; `flan-error' as well, so every path that takes an error mark down takes +;; these with it. + +(defface flan-warning-face + '((t :inherit warning :underline (:style wave))) + "Face for the text a compiler warning is about." + :group 'flan) + +(defface flan-warning-message-face + '((t :inherit warning :height 0.9)) + "Face for a warning's message, shown beside the form it is about." + :group 'flan) + +(defun flan--warning-overlays (&optional buffer) + "The Flan warning overlays in BUFFER, or in the current buffer." + (with-current-buffer (or buffer (current-buffer)) + (seq-filter (lambda (o) (overlay-get o 'flan-warning)) + (overlays-in (point-min) (point-max))))) + +(defun flan--show-warning (file line col msg) + "Mark MSG at LINE and COL of FILE, if some buffer is visiting it." + (let ((buf (flan--buffer-visiting file))) + (when buf + (with-current-buffer buf + (let* ((beg (flan--position line col)) + (end (save-excursion (goto-char beg) (line-end-position))) + (ov (make-overlay beg end buf t nil))) + (overlay-put ov 'flan-error t) + (overlay-put ov 'flan-warning t) + (overlay-put ov 'face 'flan-warning-face) + (overlay-put ov 'help-echo msg) + (overlay-put ov 'priority 90) + (overlay-put ov 'after-string + (propertize (concat " " msg) + 'face 'flan-warning-message-face)) + (add-hook 'pre-command-hook #'flan--clear-errors-on-command nil t) + t))))) + +(defun flan--report-warnings (warnings) + "Log and mark each of WARNINGS, a reply's `:warnings' list." + (dolist (w warnings) + (let ((file (plist-get w :file)) + (line (plist-get w :line)) + (col (plist-get w :col)) + (msg (plist-get w :message))) + (ignore-errors + (flan--record-diagnostic (format "%s:%d:%d" file line col) + (concat "warning: " msg))) + (ignore-errors (flan--show-warning file line col msg))))) + ;;; Inline results ;; The value of an expression, drawn after the form it came from, the way eros @@ -2599,7 +2655,8 @@ has nothing to sit beside." (names (plist-get reply :names)) (note (plist-get reply :note)) (value (plist-get reply :value)) - (stale (plist-get reply :stale))) + (stale (plist-get reply :stale)) + (warnings (plist-get reply :warnings))) ;; Accepted, so whatever the last rejection marked is no longer true. ;; Redundant now that any command clears it — the command that ran this ;; evaluation already did — and kept because it is the claim being @@ -2623,6 +2680,7 @@ has nothing to sit beside." ;; written first is wiped by whatever the drawing does to the buffer. (when value (ignore-errors (flan--show-result value at))) (when stale (ignore-errors (flan--report-stale stale))) + (when warnings (ignore-errors (flan--report-warnings warnings))) (when flan-echo-result (cond ;; An expression's value, rendered inside the running program — @@ -2646,9 +2704,13 @@ has nothing to sit beside." ;; is then empty by construction rather than a repeat of it. Now ;; that `C-x C-e' reaches this path too, that sentence is also how ;; you tell an installed declaration from an expression's `=>'. - (message "flan: %s installed in %.0f ms%s%s" + (message "flan: %s installed in %.0f ms%s%s%s" (flan--names-phrase (or fns names) what) (or (plist-get reply :ms) 0) + (if warnings + (format ", %d warning%s" (length warnings) + (if (= (length warnings) 1) "" "s")) + "") (let ((vars (and fns (seq-difference names fns)))) (if vars (format " (also %s)" (flan--names-phrase vars "")) diff --git a/emacs/test-flan.el b/emacs/test-flan.el index 6021b4dd..4f96c685 100644 --- a/emacs/test-flan.el +++ b/emacs/test-flan.el @@ -899,6 +899,30 @@ already rely on it — so nothing here is a stand-in for the real thing." (goto-char (point-max)) (delete-region beg (point-max))) + ;; A form the compiler warns about installs, and the warning is shown as an + ;; error is — marked at its site — and counted in the echo line. + (goto-char (point-max)) + (let ((beg (point))) + (insert "\n(defn spin-forever [n i64] i64\n (println n)\n (spin-forever n))") + (search-backward "(println") + (let ((said (test-flan--said (flan-eval-defun)))) + (test-flan--check "a warned-about form says so in the echo line" + (and said + (string-match-p "installed in [0-9]+ ms, 1 warning\\'" + said)))) + (test-flan--check "and the warning is marked at the call it is about" + (let ((ovs (flan--warning-overlays))) + (and (= 1 (length ovs)) + (string-match-p + "cannot return without first calling itself" + (or (overlay-get (car ovs) 'help-echo) "")) + (save-excursion + (goto-char (overlay-start (car ovs))) + (looking-at-p "(spin-forever n)"))))) + (flan-clear-errors) + (goto-char (point-max)) + (delete-region beg (point-max))) + ;; A declaration can be written where it is prose and not a declaration, and ;; the depth at its open delimiter says nothing about that: a form at column ;; 1 inside a comment or a string is at depth 0 like any other, so the head diff --git a/lib/check.ml b/lib/check.ml index 2b637a9f..5aa5e04e 100644 --- a/lib/check.ml +++ b/lib/check.ml @@ -20811,6 +20811,10 @@ let print_warnings = ref true is a build or a check, which says everything. *) let warn_within : Loc.t list option ref = ref None +(* The warnings [say_warnings] kept since [build_program] began, in order: + what a dev eval hands the editor in its reply as well as printing. *) +let said_warnings : Loc.diag list ref = ref [] + let say_warnings (ds : Loc.diag list) = let within (at : Loc.t) = match !warn_within with @@ -20822,12 +20826,13 @@ let say_warnings (ds : Loc.diag list) = && s.Loc.line <= at.Loc.line && at.Loc.line <= max s.Loc.line s.Loc.eline) spans in + let ds = List.filter (fun (d : Loc.diag) -> within d.Loc.dloc) ds in + said_warnings := !said_warnings @ ds; if !print_warnings then List.iter (fun (d : Loc.diag) -> - if within d.Loc.dloc then - prerr_endline - (Loc.entry ~mark:'~' ~label:"warning: " d.Loc.dloc d.Loc.dmsg)) + prerr_endline + (Loc.entry ~mark:'~' ~label:"warning: " d.Loc.dloc d.Loc.dmsg)) ds (* A name the renaming above made, which nobody wrote: left out of every @@ -21007,8 +21012,8 @@ let unconditional_recursion env (decls : Ast.decl list) : Loc.diag list = let fln = fln_source at in Loc.diag ~kind:"check/unconditional-recursion" at (Printf.sprintf - "%s calls itself on line %d on every path, so it never \ - returns. If that call was meant to come after %s, it is %s \ + "%s cannot return without first calling itself on line %d, \ + so it never returns. If that call was meant to come after %s, it is %s \ by mistake; otherwise %s needs a base case, a path that \ returns without calling itself" name at.Loc.line @@ -21025,6 +21030,7 @@ let unconditional_recursion env (decls : Ast.decl list) : Loc.diag list = let build_program ~keep_going ?tolerate ?previous (decls : Ast.decl list) : Tast.program * env * string list = let env = new_env () in + said_warnings := []; Hashtbl.reset arm_failed; (* ── A declaration left as it was compiled ─────────────────────────── A dev session installs a function whose signature changed, and a diff --git a/lib/dev.ml b/lib/dev.ml index 505eaeb5..40c214f3 100644 --- a/lib/dev.ml +++ b/lib/dev.ml @@ -1073,6 +1073,21 @@ let errors_field (ds : Loc.diag list) = (Wire.quote d.Loc.dmsg)) ds) ] +(* The compiler's warnings about the forms an eval sent, which it also + printed: the editor marks each where it is, as it marks an error. *) +let warnings_field (ds : Loc.diag list) = + match ds with + | [] -> [] + | ds -> + [ ":warnings " + ^ Wire.list + (List.map + (fun (d : Loc.diag) -> + Printf.sprintf "(:file %s :line %d :col %d :kind %s :message %s)" + (Wire.quote d.Loc.dloc.Loc.file) d.Loc.dloc.Loc.line + d.Loc.dloc.Loc.col (Wire.quote d.Loc.kind) (Wire.quote d.Loc.dmsg)) + ds) ] + (* A refusal with several diagnostics: the first where every refusal puts its message, all of them under [:errors]. *) let errors_reply (ds : Loc.diag list) = @@ -1118,7 +1133,7 @@ let eval ?forms ?base ?(extra = []) ?(step = false) t ~code ~origin ~pause = ^ Wire.quote "loaded; the program has ended, so this is in it when M-x \ flan-rerun starts it again" ] - @ extra) + @ warnings_field c.Session.warnings @ extra) | exception Loc.Error { Loc.dloc = l; dmsg = msg; _ } -> Session.restore t.session before; error ~loc:(Loc.to_string l) msg @@ -1136,7 +1151,7 @@ let eval ?forms ?base ?(extra = []) ?(step = false) t ~code ~origin ~pause = ok ([ ":names " ^ Wire.strings c.Session.names; ":fns ()"; ":note " ^ Wire.quote "nothing to install" ] - @ extra) + @ warnings_field c.Session.warnings @ extra) | c -> (* Everything from here to the delivery is inside the restore, and by exception type as well as by arm. The three named below are the ones @@ -1184,6 +1199,7 @@ let eval ?forms ?base ?(extra = []) ?(step = false) t ~code ~origin ~pause = Printf.sprintf ":ms %.1f" (timing.Build.llc_ms +. timing.Build.link_ms) ] @ stale_field c.Session.stale + @ warnings_field c.Session.warnings @ (match pause with | Some (l, c) -> [ ":pause " ^ Wire.quote (Printf.sprintf "%d:%d" l c) ] @@ -1227,10 +1243,16 @@ let load_file t ~code ~origin = is. *) let base = if Sys.file_exists origin then Some origin else None in let running = liveness t <> Parked in + (* A trial, which [Session.pruned] may run several times over the same + forms: only the [eval] of what survives says the warnings. *) let check forms = let before = Session.held t.session in + let was = !Check.print_warnings in + Check.print_warnings := false; Fun.protect - ~finally:(fun () -> Session.restore t.session before) + ~finally:(fun () -> + Check.print_warnings := was; + Session.restore t.session before) (fun () -> ignore (Session.eval ~origin ?base ~forms ~running t.session code)) in diff --git a/lib/session.ml b/lib/session.ml index 37edf31c..14a15517 100644 --- a/lib/session.ml +++ b/lib/session.ml @@ -688,6 +688,8 @@ type change = { change leaves behind, and the ones earlier changes left that this one did not recompile. Empty for anything that builds no module. *) stale : stale list; + (* The compiler's warnings about the forms sent, as it printed them. *) + warnings : Loc.diag list; } (* The bodies a change installed, as whoever reads the reply wrote them: a @@ -1095,6 +1097,7 @@ let eval ?(origin = "") ?base ?forms ?pause ?(step = false) ?(running = tr (* Every error in the form sent, not the first: [keep_going] checks past a refused subexpression (see [Check.check]). One error is still raised as [Loc.Error], which is what every caller of one form expects. *) + let said = ref [] in let program, env, tolerated = (* A tolerated body whose return type is read off it keeps the signature the process has for it. *) @@ -1115,7 +1118,7 @@ let eval ?(origin = "") ?base ?forms ?pause ?(step = false) ?(running = tr Check.program_tolerant ~keep_going:true ~tolerate:stale_owner ~previous decls) with - | r -> r + | r -> said := !Check.said_warnings; r | exception Loc.Errors [ d ] -> raise (Loc.Error d) in let program = @@ -1568,7 +1571,8 @@ let eval ?(origin = "") ?base ?forms ?pause ?(step = false) ?(running = tr fns <> [] || allocates || consts <> [] || run_thunk <> None; stale = stale_sites ~live ~running ~inferred:(Check.inferred_cause env) built - program } + program; + warnings = !said } (* ── Evaluating an expression ──────────────────────────────────────── *) @@ -2278,7 +2282,7 @@ let write_slot ?(origin = "") t ~frame ~(fn : Tast.fn) ~slot ~path Tast.fns = t.program.Tast.fns @ fresh; structs = t.program.Tast.structs @ copies }; Ok - ({ ir; x86 = t.x86; names = []; fns = []; installs = true; stale = [] }, + ({ ir; x86 = t.x86; names = []; fns = []; installs = true; stale = []; warnings = [] }, where, Types.to_string shown.Tast.ty)))) (* ── A typed restart, taken from the break loop ──────────────────────── *) @@ -2407,7 +2411,7 @@ let arm_restart ?(origin = "") t ~index ~(params : Types.t list) Tast.fns = t.program.Tast.fns @ fresh; structs = t.program.Tast.structs @ copies }; Ok - ({ ir; x86 = t.x86; names = []; fns = []; installs = true; stale = [] }, + ({ ir; x86 = t.x86; names = []; fns = []; installs = true; stale = []; warnings = [] }, List.map Types.to_string params) (* [pause] is [C-u C-x C-e] — §9's "last expression" target. It is a flag and @@ -2626,7 +2630,7 @@ let eval_expr ?(origin = "") ?(pause = false) ?frame t src : change = { t.program with Tast.fns = t.program.Tast.fns @ fresh; structs = t.program.Tast.structs @ copies }; - { ir; x86 = t.x86; names = []; fns = []; installs = true; stale = [] } + { ir; x86 = t.x86; names = []; fns = []; installs = true; stale = []; warnings = [] } (* ── What a macro call expands to ──────────────────────────────────── *) diff --git a/test/test_dev.ml b/test/test_dev.ml index 8c5b6b66..cb26b80e 100644 --- a/test/test_dev.ml +++ b/test/test_dev.ml @@ -9581,6 +9581,41 @@ let () = if not (contains_sub (value "(good)") "refused") then fail "a form that called one left out was installed" end; + (* A load checks its forms more than once to find the ones that do not + compile, and says each warning once: for a file that compiles whole + and for one with a form left out. The reply carries it too. *) + let times () = + let s = In_channel.with_open_bin mout In_channel.input_all in + let needle = "cannot return without first calling itself" in + let k = String.length needle and n = ref 0 in + for i = 0 to String.length s - k do + if String.sub s i k = needle then incr n + done; + !n + in + let warned what code = + let before = times () in + let r = + request mc + (Printf.sprintf "(:op \"load-file\" :file %S :code %s)" + ("programs/dev-load-" ^ what ^ ".flan") (Wire.quote code)) + in + let sent = + match Wire.field r "warnings" with + | Some { Form.v = Form.List l; _ } -> List.length l + | _ -> 0 + in + if status r <> "ok" then fail "a load of %s: %s" what (said r) + else begin + if sent <> 1 then fail "a load of %s replied with %d warnings" what sent; + let after = times () in + if after - before <> 1 then + fail "a load of %s printed its warning %d times" what (after - before) + end + in + warned "spin" "(defn spin [n i64] i64 (println n) (spin n))"; + warned "spin-bad" + "(defn spin2 [n i64] i64 (println n) (spin2 n))\n(defn bad2 [] i64 \"x\")"; (* Nothing compiles: a refusal, with the error where every refusal puts it and the list beside it. *) let r = diff --git a/test/test_flan.ml b/test/test_flan.ml index 999f402c..ec14ce7b 100644 --- a/test/test_flan.ml +++ b/test/test_flan.ml @@ -6690,8 +6690,8 @@ let () = with | Some [ (4, m) ] -> check "a self-call after a loop, outside any branch, is warned at" - (m = "count-handshakes calls itself on line 4 on every path, so it \ - never returns. If that call was meant to come after the \ + (m = "count-handshakes cannot return without first calling itself \ + on line 4, so it never returns. If that call was meant to come after the \ function, it is indented into the body by mistake; otherwise \ count-handshakes needs a base case, a path that returns without \ calling itself") @@ -6728,6 +6728,11 @@ let () = "fn g(n: i64) -> i64\n when n > 3\n return 1\n g(n + 1)\n"; quiet "a self-call behind ?? is not warned at" ~fln:true "fn c(a: i64?, n: i64) -> i64\n a ?? c(a, n)\n"; + (* A call that never comes back but is not typed Never leaves the + self-call dead, and the function still never returns, which is all the + warning claims. *) + warns "a self-call after a call that exits is warned at" ~fln:true + "fn boom() -> ()\n exit(1)\n\nfn f(n: i64) -> ()\n boom()\n f(n)\n" 6; quiet "a self-call after exit is not warned at" ~fln:true "fn q(n: i64)\n exit(1)\n q(n)\n"; quiet "a self-call after an endless loop is not warned at" ~fln:true diff --git a/test/test_session.ml b/test/test_session.ml index cbaaebe5..f222b8c4 100644 --- a/test/test_session.ml +++ b/test/test_session.ml @@ -2272,14 +2272,21 @@ let () = (match !Check.recursion_warnings with | [ d ] when d.Loc.kind = "check/unconditional-recursion" && d.Loc.dloc.Loc.line = 4 -> () | ds -> fail "a dev eval of count-handshakes found %d recursions" (List.length ds)); - if not (has said "warning: count-handshakes calls itself on line 4 on every path") + if not (has said "warning: count-handshakes cannot return without first calling itself on line 4") then fail "a dev eval printed no recursion warning: %S" said; + (match r.Session.warnings with + | [ a; b ] when a.Loc.kind = "check/shadows-builtin" + && b.Loc.kind = "check/unconditional-recursion" -> () + | ds -> fail "the eval's change carries %d warnings, not the 2 it printed" + (List.length ds)); if warnings said <> 2 then fail "the eval that sent them printed %d warnings, not 2: %S" (warnings said) said; - let _, again = + let r2, again = stderr_of (fun () -> Session.eval ~origin:"other.fln" t "fn other-thing(x: i64) -> i64\n x + 1\n") in + if r2.Session.warnings <> [] then + fail "an unrelated eval's change carries an earlier form's warnings"; if warnings again <> 0 then fail "an unrelated eval said an earlier form's warnings again: %S" again);