An eval or load reply carries the compiler's warnings, which Emacs marks at their sites and counts in the echo line, and a load says each warning once.
This commit is contained in:
parent
bbaca242e5
commit
6c2f7c34c7
@ -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 ""))
|
||||
|
||||
@ -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
|
||||
|
||||
16
lib/check.ml
16
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
|
||||
|
||||
28
lib/dev.ml
28
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
|
||||
|
||||
@ -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 = "<eval>") ?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 = "<eval>") ?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 = "<eval>") ?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 = "<set>") 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 = "<restart>") 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 = "<eval>") ?(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 ──────────────────────────────────── *)
|
||||
|
||||
|
||||
@ -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 =
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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);
|
||||
|
||||
|
||||
Loading…
x
Reference in New Issue
Block a user