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;
  (* The macro whose expansion produced whatever is at this position, if one
     did. It rides on the location rather than on the form because the location
     is the thing that already travels: [Expand.unmarshal] stamps the call
     site onto every node a macro answers with, and that stamp goes on through
     the AST and the typed IR untouched. Tagging it here means an error raised
     anywhere downstream can say which macro it is really about, with no field
     added to Form, to Ast or to Tast. *)
  macro : string option;
}

let make file line col =
  { file; line; col; eline = line; ecol = col; macro = None }

let unknown = make "<unknown>" 0 0

(** Tag a location as coming out of [name]'s expansion, unless it already names
    a macro. Already-tagged wins because the tag is applied outermost-last: the
    macro the author actually wrote is the one worth naming, not whatever it
    expanded into on the way. *)
let from_macro name (t : t) =
  match t.macro with None -> { t with macro = Some name } | Some _ -> t

(** [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 =
  (* The location already knows whether it came out of a macro, so an error
     does not have to be raised anywhere special to say so. An explicit
     [expansion] still wins, for the one caller that knows better. *)
  let expansion =
    match expansion with
    | Some _ as e -> e
    | None -> (match loc.macro with Some m -> Some (m, loc) | None -> None)
  in
  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)

(** The text of the span itself, on one line, or [None] when there is no source
    to show it from.

    This is the squiggle's other half: the squiggle points at a form in its own
    file, and this quotes the form somewhere the file is not — the x86
    backend's listing, where a comment has to say which form a run of bytes
    came from and the reader is looking at an assembly file rather than at the
    Flan. A form written across several lines is cut at the end of its first
    line with an ellipsis rather than wrapped, because the consumer is a
    one-line comment; runs of whitespace collapse for the same reason, which is
    what keeps an indented form from arriving as a column of blanks.

    A zero-width span — a location the checker invented a form for, or one an
    older reader never widened — has no end to slice to, so the rest of the
    line is quoted. That is the best answer available and it is usually the
    right one: the form the location names generally runs to the end of it. *)
let snippet ?(lim = 64) (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 t.eline > t.line || t.ecol <= t.col then n else min n (t.ecol - 1)
    in
    let raw = if stop > start then String.sub text start (stop - start) else "" in
    (* One space for any run of blanks, and nothing on either end. *)
    let b = Buffer.create (String.length raw) in
    let sp = ref false in
    String.iter
      (fun c ->
         if c = ' ' || c = '\t' || c = '\r' then sp := true
         else begin
           if !sp && Buffer.length b > 0 then Buffer.add_char b ' ';
           sp := false;
           Buffer.add_char b c
         end)
      raw;
    let s = Buffer.contents b in
    if s = "" then None
    else if String.length s > lim then Some (String.sub s 0 (max 1 (lim - 1)) ^ "…")
    else if t.eline > t.line then Some (s ^ " …")
    else Some s

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) =
  (* Source order, with the placeless ones last. A diagnostic the checker
     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
  let ds =
    List.stable_sort
      (fun a b ->
         match (placed a, placed b) with
         | true, false -> -1
         | false, true -> 1
         | _ -> 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")

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