diff --git a/lib/loc.ml b/lib/loc.ml index d79c399..e5bacb2 100644 --- a/lib/loc.ml +++ b/lib/loc.ml @@ -359,8 +359,8 @@ let report (d : diag) = it found. *) let report_all (ds : diag list) = (* Source order, with the placeless ones last. A diagnostic the checker - raised against [unknown] — a wrong [main] signature is the one that - happens — has line 0, and sorting on the number alone would put it at the + raised against [unknown] — a rule about a declaration that is not in this + file to point at — has line 0, and sorting on the number alone would put it at the top of the list, above every error that can actually be clicked. It is a real error and it is not anywhere, so it goes after the ones that are. *) let placed (d : diag) = d.dloc.line > 0 in @@ -376,3 +376,24 @@ let report_all (ds : diag list) = let n = List.length ds in String.concat "\n" (List.map report ds) ^ Printf.sprintf "\n%d error%s" n (if n = 1 then "" else "s") + +(* The last line of defence, and the one nobody plans to reach. Every driver in + this tree catches [Error] and [Errors] and prints [report]; a process that + does not — a test binary walking the corpus, a tool written in an afternoon — + dies through OCaml's default handler, and the default handler knows nothing + about this record. What it prints is [Fatal error: exception + Flan.Loc.Error(_)]: the name of a constructor, an underscore, and not one + word of the diagnostic that was carefully built to say what was wrong and + where. That is how three suite runs came to leave a message-less fatal on + stderr while reporting that they had passed. + + Registering a printer costs nothing and cannot change control flow — the + exception still propagates and still kills whatever did not catch it. All it + changes is that the corpse says which file and which line, which is the + whole of what the diagnostic was for. Drivers that do catch are unaffected: + they never ask [Printexc] anything. *) +let () = + Printexc.register_printer (function + | Error d -> Some (report d) + | Errors ds -> Some (report_all ds) + | _ -> None)