From 86296dd99ae13163ad7b4beee7949fb3fff1064b Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Sun, 13 Sep 2026 07:49:44 +0700 Subject: [PATCH] An error stops being a location and a string MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Loc.Error now carries a diagnostic: a stable kind, a span, notes that each have their own span and severity, and the macro expansion it came from. The notes are the part that was actually missing — "this is wrong here" plus "because of that, over there" is two places and two explanations, and a single string can state only one of them. The compatibility story for the daemon, which was the open question: the single-diagnostic exception stays the single-diagnostic exception. Session and dev evaluate one form and have one failure to report, so they take a location and a message out of it with Loc.summary and are otherwise unchanged. A second exception carries a list, and only a driver that compiles a whole file raises it, so nothing interactive has to know it is there. No message text changed. --- bin/main.ml | 2 +- lib/check.ml | 9 ++--- lib/dev.ml | 6 +-- lib/load.ml | 2 +- lib/loc.ml | 89 +++++++++++++++++++++++++++++++++++++++-- lib/parse.ml | 2 +- lib/session.ml | 6 +-- test/test_acceptance.ml | 12 +++--- test/test_flan.ml | 18 ++++----- test/test_session.ml | 18 ++++----- 10 files changed, 122 insertions(+), 42 deletions(-) diff --git a/bin/main.ml b/bin/main.ml index 25b9a04..105efda 100644 --- a/bin/main.ml +++ b/bin/main.ml @@ -2,7 +2,7 @@ let with_errors path f = try f () with - | Flan.Loc.Error (loc, msg) -> + | Flan.Loc.Error { Flan.Loc.dloc = loc; dmsg = msg; _ } -> Printf.eprintf "%s: %s\n" (Flan.Loc.to_string loc) msg; ignore path; exit 1 diff --git a/lib/check.ml b/lib/check.ml index d22ad87..9032cc7 100644 --- a/lib/check.ml +++ b/lib/check.ml @@ -272,12 +272,9 @@ let captured ctx loc name = "an fn is lifted into a function of its own and is handed nothing but \ its parameters. Pass it in, or use a global" in - raise - (Loc.Error - (loc, - Printf.sprintf - "%s cannot see %s: it is a local of the enclosing function, and \ - %s." what name why)) + Loc.failk "check/capture" loc + "%s cannot see %s: it is a local of the enclosing function, and %s." + what name why | _ -> () let scoped ctx f = diff --git a/lib/dev.ml b/lib/dev.ml index 6124f2d..b7c2a88 100644 --- a/lib/dev.ml +++ b/lib/dev.ml @@ -464,7 +464,7 @@ let eval t ~code ~origin = ("cannot reach the program on " ^ t.agent ^ ": " ^ Unix.error_message e)) | exception Failure m -> error m) - | exception Loc.Error (l, msg) -> error ~loc:(Loc.to_string l) msg + | exception Loc.Error { Loc.dloc = l; dmsg = msg; _ } -> error ~loc:(Loc.to_string l) msg (* Redefining a name installs a body; evaluating an expression has no name to install into, so the module carries a thunk the agent runs once. The value @@ -503,7 +503,7 @@ let eval_expr t ~code ~origin = | exception Unix.Unix_error (e, _, _) -> error ("cannot reach the program: " ^ Unix.error_message e)) | exception Failure m -> error m) - | exception Loc.Error (l, msg) -> error ~loc:(Loc.to_string l) msg + | exception Loc.Error { Loc.dloc = l; dmsg = msg; _ } -> error ~loc:(Loc.to_string l) msg let describe t = ok @@ -1779,7 +1779,7 @@ let serve t fd = let op, reply = match Wire.parse src with | req -> (Wire.string_field req "op", handle t req) - | exception Loc.Error (_, m) -> (None, error ("bad request: " ^ m)) + | exception Loc.Error { Loc.dmsg = m; _ } -> (None, error ("bad request: " ^ m)) in Wire.send fd (with_output t (with_break t reply)); if op = Some "close" then true else go () diff --git a/lib/load.ml b/lib/load.ml index 4ed981e..d126e9d 100644 --- a/lib/load.ml +++ b/lib/load.ml @@ -63,7 +63,7 @@ and pkg = { alias : string; dir : string; owns : string list; import. See [Cimport]. *) phidden : (string * string) list } -let fail loc fmt = Printf.ksprintf (fun m -> raise (Loc.Error (loc, m))) fmt +let fail loc fmt = Printf.ksprintf (fun m -> Loc.raise_diag (Loc.diag loc m)) fmt (* "vendor:raylib" -> the collection "vendor" and the subpath "raylib". A path with no colon is relative to the importing file's own directory. *) diff --git a/lib/loc.ml b/lib/loc.ml index 4c66be5..3559266 100644 --- a/lib/loc.ml +++ b/lib/loc.ml @@ -49,7 +49,90 @@ let width (t : t) = let to_string t = Printf.sprintf "%s:%d:%d" t.file t.line t.col -(** Raised by every stage of the frontend. *) -exception Error of t * string +(* ── Diagnostics ────────────────────────────────────────── -let fail loc fmt = Printf.ksprintf (fun msg -> raise (Error (loc, msg))) fmt + An error is a value rather than a location and a string, and the three parts + that make it one each buy something the pair could not express. + + [kind] is a stable id — ["reader/unterminated-string"]. It classifies + without any prose being parsed, so a message may be reworded freely and a + test that asserts on *which* error this is keeps holding. It is not a + replacement for the message: the messages here already state the reason and + name what to write instead, and none of them changed. + + [dloc] is a span, so a report can underline the thing it is about. + + [notes] are the part that makes a message good. Each carries its own span + and its own severity, so an error can say "this is wrong *here*" and + "because of *that*, over there" and point at both. One string can only ever + state one of the two, which is why volume of messages was never the whole + of what was missing. + + [expansion] names the macro call an error came from. A form a macro produced + carries the call site's location, so without this the report would point at + the call and say nothing about the code not being what was written there. It + is filled in for errors raised *during* expansion; a checker error on a form + a macro produced gets the call site's location without the macro's name, + which is a limitation and not a claim. *) + +type severity = Info | Warning | Err + +let severity_str = function + | Info -> "info" + | Warning -> "warning" + | Err -> "error" + +type note = { + nmsg : string; + nloc : t; + nsev : severity; +} + +type diag = { + kind : string; (* stable id, never printed as the reason *) + dloc : t; (* the primary span *) + dmsg : string; + notes : note list; (* in source order *) + expansion : (string * t) option; (* macro name, and its call site *) +} + +(** Raised by every stage of the frontend, one diagnostic at a time. + + This is still the single-error channel, and that is deliberate: the daemon + and [Session.eval] evaluate *one* form and have one failure to report, so + they keep catching this and take a location and a message out of it with + [summary]. Only the batch drivers — the ones that compile a whole file — + raise the list below, and nothing interactive has to know it exists. *) +exception Error of diag + +(** Raised by a driver that finished the file before reporting. Never empty, + and never raised by a path that checks a single form. *) +exception Errors of diag list + +(** The one location and one message a caller with a single line to print gets + out of a diagnostic. Notes are dropped here on purpose. *) +let summary (d : diag) = (d.dloc, d.dmsg) + +let before (a : t) (b : t) = + if a.line <> b.line then compare a.line b.line else compare a.col b.col + +(* Notes in source order, as jank sorts them: a reader follows a message that + walks down the file and loses one that jumps about. *) +let sort_notes (d : diag) = + { d with notes = List.stable_sort (fun x y -> before x.nloc y.nloc) d.notes } + +let note ?(sev = Info) loc msg = { nmsg = msg; nloc = loc; nsev = sev } + +let diag ?(kind = "error") ?(notes = []) ?expansion loc msg = + sort_notes { kind; dloc = loc; dmsg = msg; notes; expansion } + +let raise_diag d = raise (Error (sort_notes d)) + +(** The plain refusal: a span and a reason, with the generic kind. Every call + site that existed before spans is one of these and says exactly what it + said. [failk] is the same thing with a kind, notes and an expansion. *) +let fail loc fmt = + Printf.ksprintf (fun msg -> raise_diag (diag loc msg)) fmt + +let failk ?notes ?expansion kind loc fmt = + Printf.ksprintf (fun msg -> raise_diag (diag ~kind ?notes ?expansion loc msg)) fmt diff --git a/lib/parse.ml b/lib/parse.ml index 7990985..135d54c 100644 --- a/lib/parse.ml +++ b/lib/parse.ml @@ -736,7 +736,7 @@ let rec decl (f : Form.t) : Ast.decl = would be true and unhelpful. *) let rty = try texpr ret with - | Loc.Error (loc, msg) -> + | Loc.Error { Loc.dloc = loc; dmsg = msg; _ } -> Loc.fail loc "%s. This is the return type, which every defn states -- a \ function that returns nothing writes ()" msg diff --git a/lib/session.ml b/lib/session.ml index 1d11dea..b9d8561 100644 --- a/lib/session.ml +++ b/lib/session.ml @@ -505,7 +505,7 @@ let render_locals ?(origin = "") t ~frame ~(fn : Tast.fn) ~bound Some ((lit (name ^ "\t" ^ Types.to_string ty ^ "\t") :: parts) @ [ lit ("\t" ^ string_of_int i ^ "\n") ]) - | exception Loc.Error (_, why) -> + | exception Loc.Error { Loc.dmsg = why; _ } -> (* A type the structural printer has no arm for — a map, a function value, a type variable. Named, with the reason, rather than left out of the list: a local that is missing and a local that could not be @@ -794,7 +794,7 @@ let render_slot ?(origin = "") t ~frame ~(fn : Tast.fn) ~slot ~path | Error why -> Error (name ^ path_text path ^ ": " ^ why) | Ok v -> (match Render.render c 0 v with - | exception Loc.Error (_, why) -> Error (name ^ path_text path ^ ": " ^ why) + | exception Loc.Error { Loc.dmsg = why; _ } -> Error (name ^ path_text path ^ ": " ^ why) | parts -> let nullary n = { Tast.e = Tast.Call (n, []); ty = Types.Unit; loc } in t.thunks <- t.thunks + 1; @@ -875,7 +875,7 @@ let render_globals ?(origin = "") t ~(globals : Tast.global list) Some ((lit (g.Tast.gname ^ "\t" ^ Types.to_string g.Tast.gty ^ "\t") :: parts) @ [ lit "\n" ]) - | exception Loc.Error (_, why) -> + | exception Loc.Error { Loc.dmsg = why; _ } -> (* A type the structural printer has no arm for. Named with its reason rather than left out, for [render_locals]'s reason: a global that is missing and a global that could not be printed are different facts, diff --git a/test/test_acceptance.ml b/test/test_acceptance.ml index 54fd10b..188432e 100644 --- a/test/test_acceptance.ml +++ b/test/test_acceptance.ml @@ -367,7 +367,7 @@ let () = | _ -> incr failures; Printf.printf "FAIL %s\n it was accepted\n" name - | exception Loc.Error (_, m) -> + | exception Loc.Error { Loc.dmsg = m; _ } -> if not (contains m needle) then begin incr failures; Printf.printf "FAIL %s\n said: %S\n wanted: %S in it\n" @@ -1206,7 +1206,7 @@ let () = | () -> incr failures; Printf.printf "FAIL %s\n it was accepted\n" name - | exception Loc.Error (_, m) -> + | exception Loc.Error { Loc.dmsg = m; _ } -> if not (contains m needle) then begin incr failures; Printf.printf "FAIL %s\n said: %S\n wanted: %S in it\n" @@ -1567,7 +1567,7 @@ ERR@7 unexpected token: not the kind the caller was reading name n end) needles - | exception Loc.Error (_, m) -> + | exception Loc.Error { Loc.dmsg = m; _ } -> incr failures; Printf.printf "FAIL %s\n refused: %s\n" name m in @@ -1578,7 +1578,7 @@ ERR@7 unexpected token: not the kind the caller was reading | _ -> incr failures; Printf.printf "FAIL %s: accepted, and it should not have been\n" name - | exception Loc.Error (_, m) -> + | exception Loc.Error { Loc.dmsg = m; _ } -> if not (contains m fragment) then begin incr failures; Printf.printf "FAIL %s\n reason: %S\n wanted to contain: %S\n" @@ -2004,7 +2004,7 @@ ERR@7 unexpected token: not the kind the caller was reading | _ -> incr failures; Printf.printf "FAIL %s\n it was accepted\n" name - | exception Loc.Error (_, m) -> + | exception Loc.Error { Loc.dmsg = m; _ } -> if not (contains m "needs a byte-level encoder that does not exist") then begin incr failures; @@ -2034,7 +2034,7 @@ ERR@7 unexpected token: not the kind the caller was reading (defn main [] i32 (match g A 0 (B x) x))"))) with | _ -> () - | exception Loc.Error (_, m) -> + | exception Loc.Error { Loc.dmsg = m; _ } -> incr failures; Printf.printf "FAIL %s\n refused: %S\n" name m); diff --git a/test/test_flan.ml b/test/test_flan.ml index 48544e3..2616797 100644 --- a/test/test_flan.ml +++ b/test/test_flan.ml @@ -55,7 +55,7 @@ let reads name src expected = Printf.printf "FAIL %s\n src: %s\n got: %s\n wanted: %s\n" name src got expected end - | exception Loc.Error (loc, msg) -> + | exception Loc.Error { Loc.dloc = loc; dmsg = msg; _ } -> incr failures; Printf.printf "FAIL %s\n src: %s\n error: %s: %s\n" name src (Loc.to_string loc) msg @@ -73,7 +73,7 @@ let rejects ?needle name src = | exception Watchdog.Timeout -> incr failures; Printf.printf "FAIL %s: the reader did not return\n" name - | exception Loc.Error (_, msg) -> + | exception Loc.Error { Loc.dmsg = msg; _ } -> (match needle with | Some n when not (contains msg n) -> incr failures; @@ -246,7 +246,7 @@ let () = (match read ~file:"f.flan" "(f\n bad" with | _ -> check "unclosed reports opening loc" false - | exception Loc.Error (loc, _) -> + | exception Loc.Error { Loc.dloc = loc; _ } -> check "unclosed reports opening loc" (loc.line = 1 && loc.col = 1)); (* ── Spans ───────────────────────────────────────────────────── @@ -305,7 +305,7 @@ let parse_decl src = let parse_rejects ?needle name src = match read src |> Parse.program with | _ -> incr failures; Printf.printf "FAIL %s: expected a parse error\n" name - | exception Loc.Error (_, msg) -> + | exception Loc.Error { Loc.dmsg = msg; _ } -> (match needle with | Some n when not (contains msg n) -> incr failures; @@ -544,7 +544,7 @@ let () = (fun path -> match read_file path |> Parse.program with | _ -> () - | exception Loc.Error (loc, msg) -> + | exception Loc.Error { Loc.dloc = loc; dmsg = msg; _ } -> incr failures; Printf.printf "FAIL %s does not parse: %s: %s\n" path (Loc.to_string loc) msg) @@ -635,7 +635,7 @@ let infers name src expected = name src got expected end | None -> incr failures; Printf.printf "FAIL %s: no probe\n" name) - | exception Loc.Error (loc, msg) -> + | exception Loc.Error { Loc.dloc = loc; dmsg = msg; _ } -> incr failures; Printf.printf "FAIL %s\n src: %s\n error: %s: %s\n" name src (Loc.to_string loc) msg @@ -647,7 +647,7 @@ let infers name src expected = let accepts name src = match checked src with | _ -> () - | exception Loc.Error (loc, msg) -> + | exception Loc.Error { Loc.dloc = loc; dmsg = msg; _ } -> incr failures; Printf.printf "FAIL %s\n src: %s\n error: %s: %s\n" name src (Loc.to_string loc) msg @@ -663,7 +663,7 @@ let rejects_check name ?needle src = | _ -> incr failures; Printf.printf "FAIL %s: expected a type error\n src: %s\n" name src - | exception Loc.Error (_, msg) -> + | exception Loc.Error { Loc.dmsg = msg; _ } -> (match needle with | Some n when not @@ -1615,7 +1615,7 @@ let () = check "a prelude macro calling a macro is refused by name" (match Macro.reduce ring with | _ -> false - | exception Loc.Error (_, m) -> + | exception Loc.Error { Loc.dmsg = m; _ } -> contains m "the prelude macro n calls a macro"); (* ── The acceptance program checks end to end ──────────────────── *) diff --git a/test/test_session.ml b/test/test_session.ml index 94b60e9..8506b63 100644 --- a/test/test_session.ml +++ b/test/test_session.ml @@ -31,7 +31,7 @@ let refuses ?(file = "programs/reload.flan") name src reason = let t, _ = Session.create ~file () in match Session.eval t src with | _ -> fail "%s was accepted" name - | exception Loc.Error (_, msg) -> + | exception Loc.Error { Loc.dmsg = msg; _ } -> if not (has msg reason) then fail "%s\n said: %S\n wanted it to mention: %S" name msg reason @@ -128,7 +128,7 @@ let () = | exception Loc.Error _ -> ()); (match Session.eval t "(defn bump [] i64 (set counter (+ counter 6)) counter)" with | c -> if c.Session.fns <> [ "bump" ] then fail "the session did not recover" - | exception Loc.Error (_, m) -> fail "the session was poisoned by a typo: %s" m); + | exception Loc.Error { Loc.dmsg = m; _ } -> fail "the session was poisoned by a typo: %s" m); (* A declaration the program already has, with no body and no new storage, is accepted and has nothing to send. Building a module for it would report @@ -136,7 +136,7 @@ let () = program a reload it did not need. *) (match Session.eval t "(defvar counter i64)" with | c -> if c.Session.installs then fail "an empty change claimed to install" - | exception Loc.Error (_, m) -> fail "redeclaring a var unchanged: %s" m); + | exception Loc.Error { Loc.dmsg = m; _ } -> fail "redeclaring a var unchanged: %s" m); (* A constant that is only ever read at run time is just bytes in the program's memory. A dev build emits it as a mutable global and the module @@ -148,7 +148,7 @@ let () = fail "a changed run-time constant had nothing to install"; if not (has c.Session.ir "store [2 x i32]") then fail "a changed run-time constant published no new value" - | exception Loc.Error (_, m) -> fail "changing a run-time constant: %s" m); + | exception Loc.Error { Loc.dmsg = m; _ } -> fail "changing a run-time constant: %s" m); (* And in a dev build its storage is writable, where a release build keeps it immutable and gets all the folding back. *) let host = checked_program "programs/reload.flan" in @@ -174,7 +174,7 @@ let () = (* And once added, it is part of the session: a later form can use it. *) (match Session.eval t "(defn use-fresh [] i64 (set fresh 4) fresh)" with | _ -> () - | exception Loc.Error (_, m) -> fail "a name added earlier was forgotten: %s" m); + | exception Loc.Error { Loc.dmsg = m; _ } -> fail "a name added earlier was forgotten: %s" m); (* A file with imports, re-evaluated whole — the C-c C-k case. The session keeps the *expanded* declarations, so the package's names are replaced in @@ -192,7 +192,7 @@ let () = | c -> if not (List.mem "game-draw" c.Session.fns) then fail "reloading sand.flan did not include its own functions" - | exception Loc.Error (_, m) -> + | exception Loc.Error { Loc.dmsg = m; _ } -> fail "reloading a file with imports failed: %s" m); (* A form typed into a file that is *imported as a package* has to be @@ -211,7 +211,7 @@ let () = if c.Session.fns <> [ "agent/poll" ] then fail "a form from a package file reported %s, wanted agent/poll" (String.concat " " c.Session.fns) - | exception Loc.Error (_, m) -> fail "redefining agent/poll: %s" m); + | exception Loc.Error { Loc.dmsg = m; _ } -> fail "redefining agent/poll: %s" m); (* A package that is a single file, which is what sand.flan is to the headless driver. The file being edited *is* the package rather than a member of a directory, so matching on the directory alone would answer @@ -223,7 +223,7 @@ let () = if c.Session.fns <> [ "sand/step" ] then fail "a form from a single-file package reported %s, wanted sand/step" (String.concat " " c.Session.fns) - | exception Loc.Error (_, m) -> fail "redefining sand/step: %s" m); + | exception Loc.Error { Loc.dmsg = m; _ } -> fail "redefining sand/step: %s" m); (* And a file that is not a package keeps its names as written. *) (match Session.eval ~origin:"../sand.flan" t "(defn game-draw [] () (do))" with @@ -231,7 +231,7 @@ let () = if c.Session.fns <> [ "game-draw" ] then fail "a form from the program's own file reported %s" (String.concat " " c.Session.fns) - | exception Loc.Error (_, m) -> fail "redefining game-draw: %s" m); + | exception Loc.Error { Loc.dmsg = m; _ } -> fail "redefining game-draw: %s" m); (* An expression's thunk leaves nothing behind, and the module says so, which is what lets the agent unload it: nothing may point into its text