From bbaca242e5968d018f211ca7bbbda9110190de3a Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Sat, 26 Sep 2026 18:59:34 +0700 Subject: [PATCH] A dev eval prints the compiler's warnings for the forms it sent and not again for forms sent earlier. --- lib/check.ml | 52 ++++++++++++++++++++----------------- lib/session.ml | 10 +++++-- test/test_session.ml | 62 ++++++++++++++++++++++++++++---------------- 3 files changed, 76 insertions(+), 48 deletions(-) diff --git a/lib/check.ml b/lib/check.ml index 122aa2a7..2b637a9f 100644 --- a/lib/check.ml +++ b/lib/check.ml @@ -20806,6 +20806,30 @@ let prelude_alias = "prelude~" the dev program re-creating the session its launcher built and warned for. *) let print_warnings = ref true +(* Where a dev eval's own forms are, so its warnings are said for those and + not again, on every later eval, for everything the session holds. [None] + is a build or a check, which says everything. *) +let warn_within : Loc.t list option ref = ref None + +let say_warnings (ds : Loc.diag list) = + let within (at : Loc.t) = + match !warn_within with + | None -> true + | Some spans -> + List.exists + (fun (s : Loc.t) -> + String.equal s.Loc.file at.Loc.file + && s.Loc.line <= at.Loc.line && at.Loc.line <= max s.Loc.line s.Loc.eline) + spans + in + 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)) + ds + (* A name the renaming above made, which nobody wrote: left out of every listing a person reads, and shown as whose it is where a frame has to be. *) let internal_name n = String.starts_with ~prefix:(prelude_alias ^ "/") n @@ -21060,12 +21084,7 @@ let build_program ~keep_going ?tolerate ?previous (decls : Ast.decl list) : reload, which is where a defn is most likely to be written. Printed in the shape [Loc] gives an error, so a checker in an editor parses it the same way. *) - if !print_warnings then - List.iter - (fun (d : Loc.diag) -> - prerr_endline - (Loc.entry ~mark:'~' ~label:"warning: " d.Loc.dloc d.Loc.dmsg)) - (shadowed_builtins decls @ prelude_warnings); + say_warnings (shadowed_builtins decls @ prelude_warnings); (* Pass one, and it stops at the first thing it refuses. That is not laziness: every name, type and signature in the file comes from here, so a declaration this pass could not make sense of leaves a hole that pass two @@ -21079,22 +21098,12 @@ let build_program ~keep_going ?tolerate ?previous (decls : Ast.decl list) : if keep_going then env.deferred <- Some []; grow_warnings := []; let decls = collect env decls in - if !print_warnings then - List.iter - (fun (d : Loc.diag) -> - prerr_endline - (Loc.entry ~mark:'~' ~label:"warning: " d.Loc.dloc d.Loc.dmsg)) - (List.rev !pairing_warnings); + say_warnings (List.rev !pairing_warnings); check_finite env; check_union_members env; infer_returns ~keep_going ?tolerate ?previous env decls; recursion_warnings := unconditional_recursion env decls; - if !print_warnings then - List.iter - (fun (d : Loc.diag) -> - prerr_endline - (Loc.entry ~mark:'~' ~label:"warning: " d.Loc.dloc d.Loc.dmsg)) - !recursion_warnings; + say_warnings !recursion_warnings; (let late = !consts_after_infer in consts_after_infer := []; settle_consts env late); @@ -21155,12 +21164,7 @@ let build_program ~keep_going ?tolerate ?previous (decls : Ast.decl list) : | _ -> None) decls in - if !print_warnings then - List.iter - (fun (d : Loc.diag) -> - prerr_endline - (Loc.entry ~mark:'~' ~label:"warning: " d.Loc.dloc d.Loc.dmsg)) - (List.rev !grow_warnings); + say_warnings (List.rev !grow_warnings); Loc.finish s; (* The placeholder a [_] body is read against is never a type anything downstream may see; a signature carrying it would be emitted as a diff --git a/lib/session.ml b/lib/session.ml index c514bc67..37edf31c 100644 --- a/lib/session.ml +++ b/lib/session.ml @@ -1105,9 +1105,15 @@ let eval ?(origin = "") ?base ?forms ?pause ?(step = false) ?(running = tr else None) t.program.Tast.fns in + (* The whole session is checked again, and only the forms sent are warned + about: a warning said at the eval that wrote it is not said again at + every eval after. *) + let was = !Check.warn_within in + Check.warn_within := Some (List.map (fun (f : Form.t) -> f.Form.loc) forms); match - Check.program_tolerant ~keep_going:true ~tolerate:stale_owner ~previous - decls + Fun.protect ~finally:(fun () -> Check.warn_within := was) (fun () -> + Check.program_tolerant ~keep_going:true ~tolerate:stale_owner ~previous + decls) with | r -> r | exception Loc.Errors [ d ] -> raise (Loc.Error d) diff --git a/test/test_session.ml b/test/test_session.ml index 0431899e..cbaaebe5 100644 --- a/test/test_session.ml +++ b/test/test_session.ml @@ -2237,32 +2237,50 @@ let () = (* A fn sent to the session that calls itself on every path is warned at (decision 142) on the daemon's stderr, which is the daemon's buffer in - the editor. *) + the editor — once, at the eval that sent it. Every eval checks the whole + session again, and a warning about a form sent earlier is not said + again; nor is a builtin-shadow warning. *) (let t, _ = Session.create ~file:"programs/reload.flan" () in - let path = Test_support.tmp "recursion-" "stderr.txt" in - let fd = Unix.openfile path [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC ] 0o600 in - let saved = Unix.dup Unix.stderr in - flush stderr; - Unix.dup2 fd Unix.stderr; - let r = - Fun.protect - ~finally:(fun () -> flush stderr; Unix.dup2 saved Unix.stderr; Unix.close saved; Unix.close fd) - (fun () -> - Source.with_code ~syntax:Source.Indented ~at:None (fun () -> - Session.eval ~origin:"handshakes.fln" t - "fn count-handshakes(people)\n for p in range(people)\n \ - println(p)\n count-handshakes(5)\n")) + let stderr_of f = + let path = Test_support.tmp "recursion-" "stderr.txt" in + let fd = Unix.openfile path [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC ] 0o600 in + let saved = Unix.dup Unix.stderr in + flush stderr; + Unix.dup2 fd Unix.stderr; + let r = + Fun.protect + ~finally:(fun () -> + flush stderr; Unix.dup2 saved Unix.stderr; Unix.close saved; Unix.close fd) + (fun () -> Source.with_code ~syntax:Source.Indented ~at:None f) + in + let said = In_channel.with_open_bin path In_channel.input_all in + Sys.remove path; + (r, said) in - let said = In_channel.with_open_bin path In_channel.input_all in - Sys.remove path; - (match r with - | c when not (List.mem "count-handshakes" c.Session.fns) -> - fail "a fn that calls itself on every path was not installed" - | _ -> ()); + let warnings said = + List.length + (List.filter (fun l -> has l ": warning: ") (String.split_on_char '\n' said)) + in + let r, said = + stderr_of (fun () -> + Session.eval ~origin:"handshakes.fln" t + "fn count-handshakes(people)\n for p in range(people)\n \ + println(p)\n count-handshakes(5)\n\nfn get(p: i64) -> i64\n p\n") + in + if not (List.mem "count-handshakes" r.Session.fns) then + fail "a fn that calls itself on every path was not installed"; (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 warned %d times" (List.length ds)); + | 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") - then fail "a dev eval printed no recursion warning: %S" said); + then fail "a dev eval printed no recursion warning: %S" said; + if warnings said <> 2 then + fail "the eval that sent them printed %d warnings, not 2: %S" (warnings said) said; + let _, again = + stderr_of (fun () -> + Session.eval ~origin:"other.fln" t "fn other-thing(x: i64) -> i64\n x + 1\n") + in + if warnings again <> 0 then + fail "an unrelated eval said an earlier form's warnings again: %S" again); Test_support.report ~label:"session" ()