flan/lib/loc.ml

(** Source locations. Every form carries one: error messages, the step debugger
    and nREPL's find-definition all need them, and retrofitting locations onto a
    reader is far worse than carrying them from the start.

    A location is a *span*, not a point. The start is what [file:line:col]
    prints and what every consumer that wants one place uses; the end is what
    lets an error underline the thing it is about. A column number cannot draw
    a squiggle and a span can, which is the whole reason the two extra fields
    are here.

    The end is *exclusive* and defaults to the start, so a location nobody
    widened is a zero-width span at a point and every old call site keeps its
    old meaning. Only the reader knows where a form ends, so only the reader
    fills these in; a location the checker invents for a node with no syntax
    stays a point. *)

type t = {
  file  : string;
  line  : int;  (* 1-based *)
  col   : int;  (* 1-based *)
  eline : int;  (* 1-based, exclusive end *)
  ecol  : int;
}

let make file line col = { file; line; col; eline = line; ecol = col }
let unknown = make "<unknown>" 0 0

(** [upto start stop] is [start] widened to end where [stop] begins. A [stop]
    that is not after [start], or is in another file, leaves it alone: a span
    that runs backwards would draw nonsense. *)
let upto (start : t) (stop : t) =
  if
    stop.file = start.file
    && (stop.line > start.line
        || (stop.line = start.line && stop.col > start.col))
  then { start with eline = stop.line; ecol = stop.col }
  else start

(** True when the span covers more than its first line. The underline is drawn
    on the start line either way — a form that spans twenty lines is pointed
    at, not boxed — so this is what tells the renderer to run the underline to
    the end of that line rather than to [ecol]. *)
let multiline (t : t) = t.eline > t.line

(** How many columns to underline on the start line, or [None] when the span
    was never widened and there is nothing but a point to draw. *)
let width (t : t) =
  if t.eline = t.line && t.ecol > t.col then Some (t.ecol - t.col) else None

let to_string t = Printf.sprintf "%s:%d:%d" t.file t.line t.col

(* ── Diagnostics ──────────────────────────────────────────

   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

(* ── Collecting ─────────────────────────────────────────────────────

   A sink holds what a pass found, so the pass can carry on to the next thing
   rather than stop at the first. It is switched on by the caller and not by
   the code that raises, which is what keeps the interactive path exactly as it
   was: the daemon checks one form and wants one exception, so it asks for a
   sink that is off, every [caught] re-raises, and nothing downstream ever sees
   a list.

   A sink that is on is finished at a *phase* boundary and nowhere else. That
   is the whole of the resynchronisation story and it is deliberately crude:
   the hard part of recovery is not recording the error, it is not cascading
   afterwards, and a phase run on a foundation the phase before it already
   refused reports wreckage. Three real errors beat thirty of which
   twenty-seven are consequences of the first. *)

type sink = { on : bool; mutable found : diag list }

let sink ~on = { on; found = [] }

(** Run [f]. With the sink off this is [Some (f ())] and an error propagates as
    it always did. With it on, an error is recorded and the answer is [None],
    so the caller drops this one item and goes on to the next. *)
let caught s f =
  if not s.on then Some (f ())
  else
    match f () with
    | x -> Some x
    | exception Error d -> s.found <- d :: s.found; None

let any s = s.found <> []

(** Raise everything found, in the order it was found, or return if the pass
    was clean. *)
let finish s =
  match List.rev s.found with [] -> () | ds -> raise (Errors ds)

(* ── Reporting ──────────────────────────────────────────────────────

   The first line of every entry is exactly [file:line:col: message], which is
   the GNU format Emacs's compilation-mode parses with no configuration. That
   is the whole of the editor story: once more than one of these comes out,
   [M-x compile] gives a clickable list and [next-error] walks it. Everything
   below the first line is indented, and compilation-mode ignores indented
   continuation lines, so the squiggle costs nothing there.

   A note gets its own [file:line:col: note: ...] entry rather than being
   folded into the error's block, which is what gcc does and is the point of
   notes having locations at all: the second place is somewhere [next-error]
   can take you.

   Everything degrades to the first line alone. A location the checker invented
   has line 0 and a file called [<unknown>], the prelude and the REPL have
   names that are not paths, and a file may have changed under us since it was
   read — in every one of those the message still prints and nothing raises out
   of the error printer, which would turn a diagnostic into a crash. *)

let source_cache : (string, string array option) Hashtbl.t = Hashtbl.create 8

let lines_of file =
  match Hashtbl.find_opt source_cache file with
  | Some v -> v
  | None ->
    let v =
      match open_in_bin file with
      | exception _ -> None
      | ic ->
        Fun.protect ~finally:(fun () -> close_in_noerr ic) (fun () ->
          match really_input_string ic (in_channel_length ic) with
          | exception _ -> None
          | s -> Some (Array.of_list (String.split_on_char '\n' s)))
    in
    Hashtbl.replace source_cache file v;
    v

let forget_sources () = Hashtbl.reset source_cache

let source_line (t : t) =
  if t.line <= 0 then None
  else
    match lines_of t.file with
    | None -> None
    | Some ls when t.line <= Array.length ls ->
      let l = ls.(t.line - 1) in
      (* A file written on Windows leaves the carriage return in the line, and
         it would print as a stray column. *)
      let n = String.length l in
      Some (if n > 0 && l.[n - 1] = '\r' then String.sub l 0 (n - 1) else l)
    | Some _ -> None

(* The gutter is as wide as the widest line number printed, so the bars line
   up. Four digits covers every file anyone will write by hand and the rest
   simply gets a wider gutter. *)
let gutter n = String.length (string_of_int n)

(** The source line with the span underlined beneath it, or [None] when there
    is no source to show. Tabs in the prefix are copied into the underline
    rather than counted as one column, which is the only way the caret lands
    under the right character in a file that uses them. *)
let squiggle ?(mark = '^') (t : t) =
  match source_line t with
  | None -> None
  | Some text ->
    let n = String.length text in
    let start = max 0 (min (t.col - 1) n) in
    let stop =
      if multiline t then n
      else match width t with
        | Some w -> min n (start + w)
        | None -> min n (start + 1)
    in
    let stop = max stop (min n (start + 1)) in
    let pad = Buffer.create 16 in
    for i = 0 to start - 1 do
      Buffer.add_char pad (if text.[i] = '\t' then '\t' else ' ')
    done;
    let bar = String.make (max 1 (stop - start)) mark in
    let g = gutter t.line in
    Some
      (Printf.sprintf "  %*d | %s\n  %*s | %s%s" g t.line text g ""
         (Buffer.contents pad) bar)

let entry ?(mark = '^') ?(label = "") (t : t) msg =
  let head = Printf.sprintf "%s: %s%s" (to_string t) label msg in
  match squiggle ~mark t with
  | None -> head
  | Some s -> head ^ "\n" ^ s

(** One diagnostic, rendered. The error, then its notes in source order, then
    the macro call it was expanded from if it was. No trailing newline. *)
let report (d : diag) =
  let d = sort_notes d in
  let parts = ref [ entry d.dloc d.dmsg ] in
  List.iter
    (fun n ->
       let mark = match n.nsev with Info -> '-' | Warning -> '~' | Err -> '^' in
       parts :=
         entry ~mark ~label:(severity_str n.nsev ^ ": ") n.nloc n.nmsg :: !parts)
    d.notes;
  (match d.expansion with
   | None -> ()
   | Some (name, at) ->
     parts :=
       entry ~mark:'-' ~label:"note: " at
         (Printf.sprintf "expanded from the macro %s" name)
       :: !parts);
  String.concat "\n" (List.rev !parts)

(** Every diagnostic of a run, in source order, with a count. What a driver
    prints when it finished the file rather than stopping at the first thing
    it found. *)
let report_all (ds : diag list) =
  let ds = List.stable_sort (fun a b -> before a.dloc b.dloc) ds in
  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")