JosephFerano/flan
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

An error stops being a location and a string

Browse Source 
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.
This commit is contained in:
Joseph Ferano 2026-09-13 07:49:44 +07:00
parent 3295f2f640
commit 86296dd99a
10 changed files with 122 additions and 42 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
bin/main.ml
View File

@ -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

9
lib/check.ml
View File

@ -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 =

6
lib/dev.ml
View File

@ -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 ()

2
lib/load.ml
View File

@ -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. *)

89
lib/loc.ml
View File

@ -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

2
lib/parse.ml
View File

@ -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

6
lib/session.ml
View File

@ -505,7 +505,7 @@ let render_locals ?(origin = "<locals>") 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 = "<inspect>") 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 = "<globals>") 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,

12
test/test_acceptance.ml
View File

@ -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);

18
test/test_flan.ml
View File

@ -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 ──────────────────── *)

18
test/test_session.ml
View File

@ -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