Merge pull request #241 from gpetiot/block-loc

Keep locations from parsing instead of recomputing the lines, providing better error messages

Author: gpetiot

CHANGES.md

@@ -17,6 +17,7 @@
 
 - Report `#require` directive errors (#276, @gpetiot)
 - Handle no such file exception: the input file and the values of options `--root` and `--prelude` are checked (#292, @gpetiot)
+- Keep locations from parsing instead of recomputing the lines, providing better error messages (#241, @gpetiot)
 
 #### Security
 

bin/pp.ml

@@ -20,6 +20,13 @@ let src = Logs.Src.create "cram.pp"
 
 module Log = (val Logs.src_log src : Logs.LOG)
 
+let vpad_of_lines t =
+  let rec aux i = function
+    | h :: t when String.trim h = "" -> aux (i + 1) t
+    | _ -> i
+  in
+  aux 0 t
+
 let run (`Setup ()) (`File file) (`Section section) =
   Mdx.parse_file Normal file >>! fun t ->
   let t =
@@ -32,6 +39,7 @@ let run (`Setup ()) (`File file) (`Section section) =
   match t with
   | [] -> 1
   | _ ->
+      let rvpad = ref 1 in
       List.iter
         (function
           | Mdx.Section _ | Text _ -> ()
@@ -43,7 +51,10 @@ let run (`Setup ()) (`File file) (`Section section) =
                 match b.value with
                 | Toplevel _ -> Fmt.pr "%a\n" pp_lines contents
                 | OCaml _ ->
-                    Fmt.pr "%a\n%a\n" Mdx.Block.pp_line_directive (file, b.line)
+                    let vpad = vpad_of_lines contents in
+                    rvpad := vpad + !rvpad;
+                    let line = b.loc.loc_start.pos_lnum + !rvpad in
+                    Fmt.pr "%a\n%a\n" Mdx.Block.pp_line_directive (file, line)
                       pp_lines contents
                 | _ -> () ))
         t;

bin/test/main.ml

@@ -18,6 +18,7 @@ open Mdx
 open Compat
 open Result
 open Astring
+open Migrate_ast
 open Mdx.Util.Result.Infix
 
 let src = Logs.Src.create "cram.test"
@@ -84,14 +85,12 @@ let run_test ?root blacklist temp_file t =
   match snd (Unix.waitpid [] pid) with WEXITED n -> n | _ -> 255
 
 let root_dir ?root ?block () =
-  match block with
-  | Some t -> (
-      match Mdx.Block.directory t with
-      | Some d -> (
-          match root with
-          | Some r -> Some (r / d)
-          | None -> Some (Filename.dirname t.file / d) )
-      | None -> root )
+  match (block : Block.t option) with
+  | Some { dir = None; _ } -> root
+  | Some { dir = Some d; loc = { loc_start = { pos_fname; _ }; _ }; _ } -> (
+      match root with
+      | Some r -> Some (r / d)
+      | None -> Some (Filename.dirname pos_fname / d) )
   | None -> root
 
 let resolve_root file dir root =
@@ -123,11 +122,10 @@ let run_cram_tests ?syntax t ?root ppf temp_file pad tests =
     tests;
   Block.pp_footer ?syntax ppf t
 
-let eval_test ?block ?root c test =
-  Log.debug (fun l ->
-      l "eval_test %a" Fmt.(Dump.list (Fmt.fmt "%S")) (Toplevel.command test));
+let eval_test ?block ?root c cmd =
+  Log.debug (fun l -> l "eval_test %a" Fmt.(Dump.list (Fmt.fmt "%S")) cmd);
   let root = root_dir ?root ?block () in
-  with_dir root (fun () -> Mdx_top.eval c (Toplevel.command test))
+  with_dir root (fun () -> Mdx_top.eval c cmd)
 
 let err_eval ~cmd lines =
   Fmt.epr "Got an error while evaluating:\n---\n%a\n---\n%a\n%!"
@@ -137,13 +135,10 @@ let err_eval ~cmd lines =
     lines;
   exit 1
 
-let eval_raw ?block ?root c ~line lines =
-  let test =
-    Toplevel.{ vpad = 0; hpad = 0; line; command = lines; output = [] }
-  in
-  match eval_test ?block ?root c test with
+let eval_raw ?block ?root c cmd =
+  match eval_test ?block ?root c cmd with
   | Ok _ -> ()
-  | Error e -> err_eval ~cmd:lines e
+  | Error e -> err_eval ~cmd e
 
 let split_lines lines =
   let aux acc s =
@@ -153,17 +148,14 @@ let split_lines lines =
   in
   List.fold_left aux [] (List.rev lines)
 
-let eval_ocaml ~block ?syntax ?root c ppf ~line lines errors =
-  let test =
-    Toplevel.{ vpad = 0; hpad = 0; line; command = lines; output = [] }
-  in
+let eval_ocaml ~block ?syntax ?root c ppf cmd errors =
   let update ~errors = function
     | { Block.value = OCaml v; _ } as b ->
         { b with value = OCaml { v with errors } }
     (* [eval_ocaml] only called on OCaml blocks *)
     | _ -> assert false
   in
-  match eval_test ?root ~block c test with
+  match eval_test ?root ~block c cmd with
   | Ok _ -> Block.pp ?syntax ppf (update ~errors:[] block)
   | Error lines ->
       let errors =
@@ -184,8 +176,8 @@ let lines = function Ok x | Error x -> x
 let run_toplevel_tests ?syntax ?root c ppf tests t =
   Block.pp_header ?syntax ppf t;
   List.iter
-    (fun test ->
-      let lines = lines (eval_test ?root ~block:t c test) in
+    (fun (test : Toplevel.t) ->
+      let lines = lines (eval_test ?root ~block:t c test.command) in
       let lines = split_lines lines in
       let output =
         let output = List.map output_from_line lines in
@@ -304,8 +296,7 @@ let run_exn (`Setup ()) (`Non_deterministic non_deterministic)
           let det () =
             assert (syntax <> Some Cram);
             Mdx_top.in_env env (fun () ->
-                eval_ocaml ~block:t ?syntax ?root c ppf ~line:t.line t.contents
-                  errors)
+                eval_ocaml ~block:t ?syntax ?root c ppf t.contents errors)
           in
           with_non_det non_deterministic non_det ~command:print_block
             ~output:det ~det
@@ -323,18 +314,17 @@ let run_exn (`Setup ()) (`Non_deterministic non_deterministic)
       | Toplevel { non_det; env } ->
           let tests =
             let syntax = Util.Option.value syntax ~default:Normal in
-            Toplevel.of_lines ~syntax ~file:t.file ~line:t.line ~column:t.column
-              t.contents
+            Toplevel.of_lines ~syntax ~loc:t.loc t.contents
           in
           with_non_det non_deterministic non_det ~command:print_block
             ~output:(fun () ->
               assert (syntax <> Some Cram);
               print_block ();
               List.iter
-                (fun test ->
+                (fun (test : Toplevel.t) ->
                   match
                     Mdx_top.in_env env (fun () ->
-                        eval_test ~block:t ?root c test)
+                        eval_test ~block:t ?root c test.command)
                   with
                   | Ok _ -> ()
                   | Error e ->
@@ -354,7 +344,7 @@ let run_exn (`Setup ()) (`Non_deterministic non_deterministic)
     let buf = Buffer.create (String.length file_contents + 1024) in
     let ppf = Format.formatter_of_buffer buf in
     let envs = Document.envs items in
-    let eval lines () = eval_raw ?root c ~line:0 lines in
+    let eval lines () = eval_raw ?root c lines in
     let eval_in_env lines env = Mdx_top.in_env env (eval lines) in
     List.iter
       (function
@@ -391,8 +381,8 @@ let report_error_in_block block msg =
     | Cram _ -> "cram "
     | Toplevel _ -> "toplevel "
   in
-  Fmt.epr "Error in the %scode block in %s at line %d:@]\n%s\n" kind block.file
-    block.line msg
+  Fmt.epr "%a: Error in the %scode block@]\n%s\n" Location.print_loc block.loc
+    kind msg
 
 let run setup non_deterministic silent_eval record_backtrace syntax silent
     verbose_findlib prelude prelude_str file section root force_output output :

lib/block.ml

@@ -16,6 +16,7 @@
 
 open Result
 open Compat
+open Migrate_ast
 open Util.Result.Infix
 
 module Header = struct
@@ -74,9 +75,7 @@ type value =
   | Include of include_value
 
 type t = {
-  line : int;
-  column : int;
-  file : string;
+  loc : Location.t;
   section : section option;
   dir : string option;
   source_trees : string list;
@@ -111,12 +110,11 @@ let dump_value ppf = function
   | Toplevel _ -> Fmt.string ppf "Toplevel"
   | Include _ -> Fmt.string ppf "Include"
 
-let dump ppf ({ file; line; column; section; labels; contents; value; _ } as b)
-    =
+let dump ppf ({ loc; section; labels; contents; value; _ } as b) =
   Fmt.pf ppf
-    "{@[file: %s;@ line: %d;@ column: %d;@ section: %a;@ labels: %a;@ header: \
-     %a;@\n\
-    \        contents: %a;@ value: %a@]}" file line column
+    "{@[loc: %a;@ section: %a;@ labels: %a;@ header: %a;@ contents: %a;@ \
+     value: %a@]}"
+    Location.print_loc loc
     Fmt.(Dump.option dump_section)
     section
     Fmt.Dump.(list Label.pp)
@@ -130,7 +128,8 @@ let pp_lines syntax t =
   let pp =
     match syntax with
     | Some Syntax.Cram -> Fmt.fmt "  %s"
-    | Some Syntax.Mli -> fun ppf -> Fmt.fmt "%*s%s" ppf (t.column + 2) ""
+    | Some Syntax.Mli ->
+        fun ppf -> Fmt.fmt "%*s%s" ppf (t.loc.loc_start.pos_cnum + 2) ""
     | _ -> Fmt.string
   in
   Fmt.(list ~sep:(unit "\n") pp)
@@ -276,18 +275,16 @@ let executable_contents ~syntax b =
     | OCaml _ -> b.contents
     | Raw _ | Cram _ | Include _ -> []
     | Toplevel _ ->
-        let phrases =
-          Toplevel.of_lines ~syntax ~file:b.file ~line:b.line ~column:b.column
-            b.contents
-        in
+        let phrases = Toplevel.of_lines ~syntax ~loc:b.loc b.contents in
         List.flatten
           (List.map
-             (fun t ->
-               match Toplevel.command t with
+             (fun (t : Toplevel.t) ->
+               match t.command with
                | [] -> []
                | cs ->
                    let mk s = String.make (t.hpad + 2) ' ' ^ s in
-                   line_directive (b.file, t.line) :: List.map mk cs)
+                   line_directive (t.pos.pos_fname, t.pos.pos_lnum)
+                   :: List.map mk cs)
              phrases)
   in
   if contents = [] || ends_by_semi_semi contents then contents
@@ -437,8 +434,7 @@ let infer_block ~config ~header ~contents ~errors =
           >>= fun () ->
           check_no_errors errors >>| fun () -> Raw { header } )
 
-let mk ~line ~file ~column ~section ~labels ~legacy_labels ~header ~contents
-    ~errors =
+let mk ~loc ~section ~labels ~legacy_labels ~header ~contents ~errors =
   let block_kind =
     get_label (function Block_kind x -> Some x | _ -> None) labels
   in
@@ -452,9 +448,7 @@ let mk ~line ~file ~column ~section ~labels ~legacy_labels ~header ~contents
   >>= fun value ->
   version_enabled config.version >>| fun version_enabled ->
   {
-    line;
-    file;
-    column;
+    loc;
     section;
     dir = config.dir;
     source_trees = config.source_trees;
@@ -469,12 +463,12 @@ let mk ~line ~file ~column ~section ~labels ~legacy_labels ~header ~contents
     value;
   }
 
-let mk_include ~line ~file ~column ~section ~labels =
+let mk_include ~loc ~section ~labels =
   match get_label (function File x -> Some x | _ -> None) labels with
   | Some file_inc ->
       let header = Header.infer_from_file file_inc in
-      mk ~line ~file ~column ~section ~labels ~legacy_labels:false ~header
-        ~contents:[] ~errors:[]
+      mk ~loc ~section ~labels ~legacy_labels:false ~header ~contents:[]
+        ~errors:[]
   | None -> label_required ~label:"file" ~kind:"include"
 
 let is_active ?section:s t =

lib/block.mli

@@ -75,9 +75,7 @@ type section = int * string
 (** The type for sections. *)
 
 type t = {
-  line : int;
-  column : int;
-  file : string;
+  loc : Location.t;
   section : section option;
   dir : string option;
   source_trees : string list;
@@ -95,9 +93,7 @@ type t = {
 (** The type for supported code blocks. *)
 
 val mk :
-  line:int ->
-  file:string ->
-  column:int ->
+  loc:Location.t ->
   section:section option ->
   labels:Label.t list ->
   legacy_labels:bool ->
@@ -107,9 +103,7 @@ val mk :
   (t, [ `Msg of string ]) Result.result
 
 val mk_include :
-  line:int ->
-  file:string ->
-  column:int ->
+  loc:Location.t ->
   section:section option ->
   labels:Label.t list ->
   (t, [ `Msg of string ]) Result.result