Merge pull request #539 from NathanReb/fix-test-for-5-3

Add new `[%%expect_in <version-range> {| ... |}]` syntax for expect tests and fix 5.3 builds

test/code_path/test.ml

@@ -89,11 +89,16 @@ module Functor() = struct
   end
 end
 let _ = let module M = Functor() in !M.code_path
-[%%expect{|
+[%%expect_in <= 5.2 {|
 module Functor : functor () -> sig val code_path : string ref end
 - : string =
 "(code_path(main_module_name Test)(submodule_path(Functor _))(enclosing_module First_class)(enclosing_value(x))(value(x))(fully_qualified_path Test.Functor._.x))"
 |}]
+[%%expect_in >= 5.3 {|
+module Functor : () -> sig val code_path : string ref end
+- : string =
+"(code_path(main_module_name Test)(submodule_path(Functor _))(enclosing_module First_class)(enclosing_value(x))(value(x))(fully_qualified_path Test.Functor._.x))"
+|}]
 
 module Actual = struct
   let code_path = [%code_path]

test/expect/expect_lexer.mli

@@ -1,2 +1,21 @@
-val split_file :
-  file_contents:string -> Lexing.lexbuf -> (Lexing.position * string) list
+type version = int * int
+
+type version_range =
+  | Only of version
+  | Up_to of version
+  | From of version
+  | Between of version * version
+
+(*[[%%ignore]], [[%%expect{|...|}] or [%%expect_in 5.3 {|...|}]*)
+type expect_block =
+  | Ignore
+  | Regular
+  | Versioned of (version_range * string) list
+
+type chunk = {
+  phrases : string;
+  phrases_start : Lexing.position;
+  expect : expect_block;
+}
+
+val split_file : file_contents:string -> Lexing.lexbuf -> chunk list

test/expect/expect_lexer.mll

@@ -1,40 +1,194 @@
 {
 open StdLabels
+
+type version = int * int
+
+type version_range =
+  | Only of version (* ex: [%%expect_in 5.3 *)
+  | Up_to of version (* ex: [%%expect_in <= 5.3 *)
+  | From of version (* ex: [%%expect_in >= 5.3 *)
+  | Between of version * version (* ex: [%%expect_in 5.0 <=> 5.3 *)
+
+(*[%%ignore], [%%expect] or [%%expect_in]*)
+type expect_block =
+  | Ignore
+  | Regular
+  | Versioned of (version_range * string) list
+
+type chunk =
+  { phrases : string
+  ; phrases_start : Lexing.position
+  ; expect : expect_block
+  }
+
+let make_version major minor =
+  let major = int_of_string major in
+  let minor = int_of_string minor in
+  (major, minor)
+
+let extract_string all_file start lexbuf =
+  let pos = start.Lexing.pos_cnum in
+  let len = Lexing.lexeme_start lexbuf - pos in
+  String.sub all_file ~pos ~len
 }
 
-rule code txt start = parse
+let digit = ['0'-'9']
+
+(* Entrypoint
+   Parses blocks of code to execute seperated by [%%expect{|...|}] statement.
+   Code blocks can be separated by a single [%%expect{|...|}] statement or by a
+   series of [%%expect_in <version-range> {|...|}]. *)
+rule code all_file phrases_start = parse
   | "[%%expect{|\n" {
-    let pos = start.Lexing.pos_cnum in
-    let len = Lexing.lexeme_start lexbuf - pos in
-    let s = String.sub txt ~pos ~len in
+    let phrases = extract_string all_file phrases_start lexbuf in
     Lexing.new_line lexbuf;
-    (start, s) :: expectation txt lexbuf
+    let chunk = {phrases; phrases_start; expect = Regular} in
+    chunk :: expectation all_file lexbuf
+  }
+  | "[%%ignore]\n" {
+    let phrases = extract_string all_file phrases_start lexbuf in
+    Lexing.new_line lexbuf;
+    let chunk = {phrases; phrases_start; expect = Ignore} in
+    chunk :: code all_file lexbuf.lex_curr_p lexbuf
+  }
+  | "[%%expect_in " (digit+ as major) '.' (digit+ as minor) " {|\n" {
+      let phrases = extract_string all_file phrases_start lexbuf in
+      Lexing.new_line lexbuf;
+      let version = make_version major minor in
+      let range = Only version in
+      let start = lexbuf.lex_curr_p in
+      versioned_expectation_content all_file
+        (phrases_start, phrases) [] (range, start) lexbuf
+  }
+  | "[%%expect_in >= " (digit+ as major) '.' (digit+ as minor) " {|\n" {
+      let phrases = extract_string all_file phrases_start lexbuf in
+      Lexing.new_line lexbuf;
+      let version = make_version major minor in
+      let range = From version in
+      let start = lexbuf.lex_curr_p in
+      versioned_expectation_content all_file
+        (phrases_start, phrases) [] (range, start) lexbuf
+  }
+  | "[%%expect_in <= " (digit+ as major) '.' (digit+ as minor) " {|\n" {
+      let phrases = extract_string all_file phrases_start lexbuf in
+      Lexing.new_line lexbuf;
+      let version = make_version major minor in
+      let range = Up_to version in
+      let start = lexbuf.lex_curr_p in
+      versioned_expectation_content all_file
+        (phrases_start, phrases) [] (range, start) lexbuf
+  }
+  | "[%%expect_in "
+    (digit+ as major1) '.' (digit+ as minor1)
+    " <=> "
+    (digit+ as major2) '.' (digit+ as minor2)
+    " {|\n" {
+      let phrases = extract_string all_file phrases_start lexbuf in
+      Lexing.new_line lexbuf;
+      let v1 = make_version major1 minor1 in
+      let v2 = make_version major2 minor2 in
+      let range = Between (v1, v2) in
+      let start = lexbuf.lex_curr_p in
+      versioned_expectation_content all_file
+        (phrases_start, phrases) [] (range, start) lexbuf
   }
   | [^'\n']*'\n' {
     Lexing.new_line lexbuf;
-    code txt start lexbuf
+    code all_file phrases_start lexbuf
   }
   | eof {
-    let pos = start.Lexing.pos_cnum in
-    let len = String.length txt - pos in
+    let pos = phrases_start.Lexing.pos_cnum in
+    let len = String.length all_file - pos in
     if pos > 0 then begin
-      let s = String.sub txt ~pos ~len in
-      if String.trim s = "" then
+      let phrases = String.sub all_file ~pos ~len in
+      if String.trim phrases = "" then
         []
       else
-        [(start, s)]
+        [{phrases_start; phrases; expect = Regular}]
     end else
       []
   }
 
-and expectation txt = parse
+and expectation all_file = parse
   | "|}]\n" {
       Lexing.new_line lexbuf;
-      code txt lexbuf.lex_curr_p lexbuf
+      code all_file lexbuf.lex_curr_p lexbuf
     }
   | [^'\n']*'\n' {
     Lexing.new_line lexbuf;
-    expectation txt lexbuf
+    expectation all_file lexbuf
+  }
+
+(* Parses the content of a [%%expect_in .. {| ... |}] block along with following
+   blocks in the same group *)
+and versioned_expectation_content all_file code_chunk vexpects curr = parse
+  | "|}]\n[%%expect_in " (digit+ as major) '.' (digit+ as minor) " {|\n" {
+    let range, start = curr in
+    let s = extract_string all_file start lexbuf in
+    Lexing.new_line lexbuf;
+    Lexing.new_line lexbuf;
+    let block = range, s in
+    let version = make_version major minor in
+    let next_range = Only version in
+    let cstart = lexbuf.lex_curr_p in
+    versioned_expectation_content all_file code_chunk
+      (block::vexpects) (next_range, cstart) lexbuf
+  }
+  | "|}]\n[%%expect_in >= " (digit+ as major) '.' (digit+ as minor) " {|\n" {
+    let range, start = curr in
+    let s = extract_string all_file start lexbuf in
+    Lexing.new_line lexbuf;
+    Lexing.new_line lexbuf;
+    let block = range, s in
+    let version = make_version major minor in
+    let next_range = From version in
+    let cstart = lexbuf.lex_curr_p in
+    versioned_expectation_content all_file code_chunk
+      (block::vexpects) (next_range, cstart) lexbuf
+  }
+  | "|}]\n[%%expect_in <= " (digit+ as major) '.' (digit+ as minor) " {|\n" {
+    let range, start = curr in
+    let s = extract_string all_file start lexbuf in
+    Lexing.new_line lexbuf;
+    Lexing.new_line lexbuf;
+    let block = range, s in
+    let version = make_version major minor in
+    let next_range = Up_to version in
+    let cstart = lexbuf.lex_curr_p in
+    versioned_expectation_content all_file code_chunk
+      (block::vexpects) (next_range, cstart) lexbuf
+  }
+  | "|}]\n[%%expect_in "
+    (digit+ as major1) '.' (digit+ as minor1)
+    " <=> "
+    (digit+ as major2) '.' (digit+ as minor2)
+    " {|\n" {
+    let range, start = curr in
+    let s = extract_string all_file start lexbuf in
+    Lexing.new_line lexbuf;
+    Lexing.new_line lexbuf;
+    let block = range, s in
+    let v1 = make_version major1 minor1 in
+    let v2 = make_version major2 minor2 in
+    let next_range = Between (v1, v2) in
+    let cstart = lexbuf.lex_curr_p in
+    versioned_expectation_content all_file code_chunk
+      (block::vexpects) (next_range, cstart) lexbuf
+  }
+  | "|}]\n" {
+    let range, start = curr in
+    let pos = start.Lexing.pos_cnum in
+    let len = Lexing.lexeme_start lexbuf - pos in
+    let s = String.sub all_file ~pos ~len in
+    Lexing.new_line lexbuf;
+    let vexpects = List.rev ((range, s)::vexpects) in
+    let phrases_start, phrases = code_chunk in
+    let chunk = {phrases; phrases_start; expect = Versioned vexpects} in
+    chunk :: code all_file lexbuf.lex_curr_p lexbuf
+  }
+  | [^'\n']*'\n' {
+    Lexing.new_line lexbuf;
+    versioned_expectation_content all_file code_chunk vexpects curr lexbuf
   }
 
 {

test/expect/expect_test.ml

@@ -1,5 +1,21 @@
 open StdLabels
 
+let compiler_version =
+  match String.split_on_char ~sep:'.' Sys.ocaml_version with
+  | major :: minor :: _ -> (int_of_string major, int_of_string minor)
+  | _ -> assert false
+
+let include_compiler_version range =
+  let cmajor, cminor = compiler_version in
+  match (range : Expect_lexer.version_range) with
+  | Only (major, minor) -> cmajor = major && cminor = minor
+  | From (major, minor) -> cmajor > major || (cmajor = major && cminor >= minor)
+  | Up_to (major, minor) -> cmajor < major || (cmajor = major && cminor <= minor)
+  | Between ((min_major, min_minor), (max_major, max_minor)) ->
+      (cmajor > min_major && cmajor < max_major)
+      || (cmajor = min_major && cminor >= min_minor)
+      || (cmajor = max_major && cminor <= max_minor)
+
 let read_file file =
   let ic = open_in_bin file in
   let len = in_channel_length ic in
@@ -73,6 +89,71 @@ let execute_phrase ppf phr =
   in
   match trimmed with "" -> () | _ -> Format.fprintf ppf "%s\n" trimmed
 
+let pp_version ppf (major, minor) = Format.fprintf ppf "%d.%d" major minor
+
+let pp_range ppf range =
+  match (range : Expect_lexer.version_range) with
+  | Only v -> pp_version ppf v
+  | From v -> Format.fprintf ppf ">= %a" pp_version v
+  | Up_to v -> Format.fprintf ppf "<= %a" pp_version v
+  | Between (v1, v2) ->
+      Format.fprintf ppf "%a <=> %a" pp_version v1 pp_version v2
+
+let run_code ppf starting_pos code =
+  let lexbuf = Lexing.from_string code in
+  lexbuf.lex_curr_p <- { starting_pos with pos_lnum = 1 };
+  let phrases = !Toploop.parse_use_file lexbuf in
+  List.iter phrases ~f:(function
+    | Parsetree.Ptop_def [] -> ()
+    | phr -> (
+        try
+          let phr = apply_rewriters phr in
+          if !Clflags.dump_source then
+            Format.fprintf ppf "%a@?" Ppxlib.Pprintast.top_phrase
+              (Ppxlib.Selected_ast.Of_ocaml.copy_toplevel_phrase phr);
+          execute_phrase ppf phr
+        with exn -> Location.report_exception ppf exn))
+
+let trash_buffer = Buffer.create 1024
+let trash_ppf = Format.formatter_of_buffer trash_buffer
+
+let handle_ignore_block ppf starting_pos code =
+  Format.fprintf ppf "%s[%%%%ignore]@." code;
+  run_code trash_ppf starting_pos code;
+  Buffer.clear trash_buffer
+
+let handle_regular_expect_block ppf starting_pos code =
+  Format.fprintf ppf "%s[%%%%expect{|@." code;
+  run_code ppf starting_pos code;
+  Format.fprintf ppf "@?|}]@."
+
+let handle_versioned_expect_blocks ppf starting_pos code vexpect_blocks =
+  let matched = ref false in
+  let loc =
+    {
+      Ppxlib.Location.loc_start = starting_pos;
+      loc_end = starting_pos;
+      loc_ghost = false;
+    }
+  in
+  Format.fprintf ppf "%s@?" code;
+  List.iter vexpect_blocks ~f:(fun (range, content) ->
+      Format.fprintf ppf "[%%%%expect_in %a {|@." pp_range range;
+      if include_compiler_version range && not !matched then (
+        matched := true;
+        run_code ppf starting_pos code;
+        Format.fprintf ppf "@?|}]@.")
+      else if include_compiler_version range && !matched then
+        Ppxlib.Location.raise_errorf ~loc
+          "Multiple versioned expect block in a group matched our compiler \
+           version %a"
+          pp_version compiler_version
+      else Format.fprintf ppf "%s|}]@." content);
+  if not !matched then
+    Ppxlib.Location.raise_errorf ~loc
+      "No versioned expect block in a group matched our compiler version %a"
+      pp_version compiler_version
+
 let main () =
   let rec map_tree = function
     | Outcometree.Oval_constr (name, params) ->
@@ -119,22 +200,13 @@ let main () =
          is statically linked in *)
       Topfind.load_deeply [ "ppxlib" ];
 
-      List.iter chunks ~f:(fun (pos, s) ->
-          Format.fprintf ppf "%s[%%%%expect{|@." s;
-          let lexbuf = Lexing.from_string s in
-          lexbuf.lex_curr_p <- { pos with pos_lnum = 1 };
-          let phrases = !Toploop.parse_use_file lexbuf in
-          List.iter phrases ~f:(function
-            | Parsetree.Ptop_def [] -> ()
-            | phr -> (
-                try
-                  let phr = apply_rewriters phr in
-                  if !Clflags.dump_source then
-                    Format.fprintf ppf "%a@?" Ppxlib.Pprintast.top_phrase
-                      (Ppxlib.Selected_ast.Of_ocaml.copy_toplevel_phrase phr);
-                  execute_phrase ppf phr
-                with exn -> Location.report_exception ppf exn));
-          Format.fprintf ppf "@?|}]@.");
+      List.iter chunks
+        ~f:(fun { Expect_lexer.phrases; phrases_start; expect } ->
+          match expect with
+          | Ignore -> handle_ignore_block ppf phrases_start phrases
+          | Regular -> handle_regular_expect_block ppf phrases_start phrases
+          | Versioned vexpects ->
+              handle_versioned_expect_blocks ppf phrases_start phrases vexpects);
       Buffer.contents buf)
 
 let () =