unikernel/duniverse/ppxlib/test/expect/dune

@@ -0,0 +1,26 @@
+(executable
+ (name expect_test)
+ (enabled_if
+  (>= %{ocaml_version} "4.08.0"))
+ (link_flags (-linkall))
+ (modes byte)
+ (libraries
+  unix
+  compiler-libs.toplevel
+  ppxlib
+  ppxlib.metaquot
+  ppxlib.traverse
+  ppxlib.astlib
+  findlib.top
+  ppxlib_ast
+  ;; We don't actually use findlib.dynload, however it is a
+  ;; special library that causes to record the various
+  ;; libraries statically linked in with findlib so that
+  ;; they are not loaded dynamically at runtime
+  findlib.dynload))
+
+(ocamllex expect_lexer)
+
+(cinaps
+ (files expect_test.ml)
+ (libraries ppxlib_cinaps_helpers))

unikernel/duniverse/ppxlib/test/expect/expect_lexer.mli

@@ -0,0 +1,21 @@
+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

unikernel/duniverse/ppxlib/test/expect/expect_lexer.mll

@@ -0,0 +1,197 @@
+{
+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
+}
+
+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 phrases = extract_string all_file phrases_start lexbuf in
+    Lexing.new_line 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 all_file phrases_start lexbuf
+  }
+  | eof {
+    let pos = phrases_start.Lexing.pos_cnum in
+    let len = String.length all_file - pos in
+    if pos > 0 then begin
+      let phrases = String.sub all_file ~pos ~len in
+      if String.trim phrases = "" then
+        []
+      else
+        [{phrases_start; phrases; expect = Regular}]
+    end else
+      []
+  }
+
+and expectation all_file = parse
+  | "|}]\n" {
+      Lexing.new_line lexbuf;
+      code all_file lexbuf.lex_curr_p lexbuf
+    }
+  | [^'\n']*'\n' {
+    Lexing.new_line 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
+  }
+
+{
+  let split_file ~file_contents lexbuf =
+    code file_contents lexbuf.Lexing.lex_curr_p lexbuf
+}

unikernel/duniverse/ppxlib/test/expect/expect_test.ml

@@ -0,0 +1,218 @@
+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
+  let file_contents = really_input_string ic len in
+  close_in ic;
+  file_contents
+
+let run_expect_test file ~f =
+  let file_contents = read_file file in
+  let lexbuf = Lexing.from_string file_contents in
+  lexbuf.lex_curr_p <-
+    { pos_fname = file; pos_cnum = 0; pos_lnum = 1; pos_bol = 0 };
+
+  let expected = f file_contents lexbuf in
+
+  let corrected_file = file ^ ".corrected" in
+  if file_contents <> expected then (
+    let oc = open_out_bin corrected_file in
+    output_string oc expected;
+    close_out oc)
+  else (
+    if Sys.file_exists corrected_file then Sys.remove corrected_file;
+    exit 0)
+
+let capture_trimmed_fmt printer arg =
+  let buf = Buffer.create 1024 in
+  let buf_fmt = Format.formatter_of_buffer buf in
+  printer buf_fmt arg;
+  String.trim (Buffer.contents buf)
+
+let print_loc _ _ ppf (loc : Location.t) =
+  let startchar = loc.loc_start.pos_cnum - loc.loc_start.pos_bol in
+  let endchar = loc.loc_end.pos_cnum - loc.loc_start.pos_cnum + startchar in
+  Format.fprintf ppf "Line _";
+  if startchar >= 0 then
+    Format.fprintf ppf ", characters %d-%d" startchar endchar;
+  Format.fprintf ppf ":@."
+
+let report_printer () =
+  let default = Location.default_report_printer () in
+  let trimmed_pp report_printer ppf report =
+    let trimmed = capture_trimmed_fmt (default.pp report_printer) report in
+    Format.fprintf ppf "%s\n" trimmed
+  in
+  {
+    default with
+    pp = trimmed_pp;
+    pp_main_loc = print_loc;
+    pp_submsg_loc = print_loc;
+  }
+
+let setup_printers ppf =
+  Location.formatter_for_warnings := ppf;
+  Location.warning_reporter := Location.default_warning_reporter;
+  Location.report_printer := report_printer;
+  Location.alert_reporter := Location.default_alert_reporter
+
+let apply_rewriters : Parsetree.toplevel_phrase -> Parsetree.toplevel_phrase =
+  function
+  | Ptop_dir _ as x -> x
+  | Ptop_def s ->
+      let s = Ppxlib.Selected_ast.of_ocaml Structure s in
+      let s' = Ppxlib.Driver.map_structure s in
+      Ptop_def (Ppxlib.Selected_ast.to_ocaml Structure s')
+
+let execute_phrase ppf phr =
+  let trimmed =
+    capture_trimmed_fmt
+      (fun ppf phr -> ignore (Toploop.execute_phrase true ppf phr))
+      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) ->
+        Outcometree.Oval_constr (name, List.map ~f:map_tree params)
+    | Oval_variant (name, Some param) ->
+        Oval_variant (name, Some (map_tree param))
+    | Oval_string (s, maxlen, kind) ->
+        Oval_string (s, (if maxlen < 8 then 8 else maxlen), kind)
+    (*IF_NOT_AT_LEAST 504 | Oval_tuple tl -> Oval_tuple (List.map ~f:map_tree tl) *)
+    (*IF_AT_LEAST 504 | Oval_tuple tl -> Oval_tuple (List.map ~f:(fun (label, v) -> (label, map_tree v)) tl) *)
+    (*IF_NOT_AT_LEAST 504 | Oval_array tl -> Oval_array (List.map ~f:map_tree tl) *)
+    (*IF_AT_LEAST 504 | Oval_array (tl, mutable_) -> Oval_array ((List.map ~f:map_tree tl), mutable_) *)
+    | Oval_list tl -> Oval_list (List.map ~f:map_tree tl)
+    | Oval_record fel ->
+        Oval_record
+          (List.map ~f:(fun (name, tree) -> (name, map_tree tree)) fel)
+    | tree -> tree
+  in
+  let print_out_value = !Toploop.print_out_value in
+  (* Achieve 4.14 printing behaviour, as introduced in
+     https://github.com/ocaml/ocaml/pull/10565 *)
+  (Toploop.print_out_value :=
+     fun ppf tree -> print_out_value ppf (map_tree tree));
+  run_expect_test Sys.argv.(1) ~f:(fun file_contents lexbuf ->
+      let chunks = Expect_lexer.split_file ~file_contents lexbuf in
+
+      let buf = Buffer.create (String.length file_contents + 1024) in
+      let ppf = Format.formatter_of_buffer buf in
+      setup_printers ppf;
+      Topfind.log := ignore;
+
+      let _ = Warnings.parse_options false "@a-4-29-40-41-42-44-45-48-58" in
+      Clflags.real_paths := false;
+      Toploop.initialize_toplevel_env ();
+
+      (* Findlib stuff *)
+      let preds = [ "toploop" ] in
+      let preds =
+        match Sys.backend_type with
+        | Native -> "native" :: preds
+        | Bytecode -> "byte" :: preds
+        | Other _ -> preds
+      in
+      Topfind.add_predicates preds;
+      (* This just adds the include directories since the [ppx] library
+         is statically linked in *)
+      Topfind.load_deeply [ "ppxlib" ];
+
+      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 () =
+  try main ()
+  with exn ->
+    Location.report_exception Format.err_formatter exn;
+    exit 1