Stop at the first failure

lib/top/vif_top.ml

@@ -4,6 +4,8 @@ module Log = (val Logs.src_log src : Logs.LOG)
 
 type cfg = { stdlib: Fpath.t; roots: string list }
 
+external reraise : exn -> 'a = "%reraise"
+
 let errors = ref false
 
 module Lexbuf = struct
@@ -49,6 +51,9 @@ module Lexbuf = struct
     { default_mapper with location }
 end
 
+let pp_location ppf { Lexing.pos_fname; pos_lnum; pos_bol; _ } =
+  Fmt.pf ppf "%S %@ l.%d.%d" pos_fname pos_lnum pos_bol
+
 module Phrase = struct
   open Lexing
   open Parsetree
@@ -79,6 +84,9 @@ module Phrase = struct
             match error_of_exn exn with
             | None -> raise exn
             | Some error ->
+                Log.err (fun m ->
+                    m "Shift (%a) syntax error: %s" pp_location startpos
+                      (Printexc.to_string exn));
                 Location.Error (Lexbuf.shift_location_error startpos error)
           in
           begin
@@ -292,7 +300,17 @@ let cut_into_phrases lst =
   in
   go [] [] lst
 
-let eval cfg cmd =
+let retrieve_report exn =
+  let rec loop n exn =
+    match Location.error_of_exn exn with
+    | None -> reraise exn
+    | Some `Already_displayed -> None
+    | Some (`Ok report) -> Some report
+    | exception exn when n > 0 -> loop (n - 1) exn
+  in
+  loop 5 exn
+
+let eval cfg file =
   let ppf = Format.formatter_of_out_channel stderr in
   errors := false;
   let eval phrase =
@@ -303,25 +321,44 @@ let eval cfg cmd =
     in
     Oprint.out_phrase := fn_out_phrase;
     let restore () = Oprint.out_phrase := out_phrase in
-    begin
+    let result =
       match eval cfg ppf phrase with
       | ok ->
           errors := (not ok) || !errors;
-          restore ()
+          restore ();
+          Ok ()
       | exception exn ->
+          Log.err (fun m ->
+              m "Got an exception while evaluation: %s" (Printexc.to_string exn));
           errors := true;
           restore ();
-          Location.report_exception ppf exn
+          Error (retrieve_report exn)
-    end;
+    in
-    Format.pp_print_flush ppf ()
+    Format.pp_print_flush ppf ();
+    result
   in
   capture_compiler_stuff ppf @@ fun () ->
-  let cmd =
+  let file =
-    match cmd with [] | [ _ ] -> cmd | x :: r -> x :: List.map (( ^ ) " ") r
+    match file with [] | [ _ ] -> file | x :: r -> x :: List.map (( ^ ) " ") r
   in
-  let phrases = cut_into_phrases cmd in
+  let phrases = cut_into_phrases file in
-  List.iter
+  let fn acc phrase =
-    (fun phrase ->
+    match acc with
-      match Phrase.parse phrase with Some t -> eval t | None -> ())
+    | Error _ as err -> err
-    phrases;
+    | Ok () -> (
-  if !errors then Error () else Ok ()
+        Log.debug (fun m ->
+            m "Parse phrase: %a" Fmt.(Dump.list (fmt "%S")) phrase);
+        match Phrase.parse phrase with
+        | Some t ->
+            Log.debug (fun m ->
+                m "Eval phrase: %a" Fmt.(Dump.list (fmt "%S")) phrase);
+            begin
+              match eval t with
+              | Ok () -> Ok ()
+              | Error reports -> Error (`Reports reports)
+            end
+        | None -> Error `Syntax)
+  in
+  match List.fold_left fn (Ok ()) phrases with
+  | Ok _ as value -> value
+  | Error _ -> Error ()