feature(boot): strip let%expect_test

allows us to write ppx_expect tests in more places without depending on
the ppx itself

As an example, add some unit tests for Dune_sexp.Escape. These will be
handy once we drop support for pre 4.14

Signed-off-by: Rudi Grinberg <me@rgrinberg.com>

Author: rgrinberg

boot/bootstrap.ml

@@ -25,7 +25,8 @@ let keep_generated_files =
   !keep_generated_files
 ;;
 
-let modules = [ "boot/types"; "boot/libs"; "boot/duneboot" ]
+let pps = "boot/pps"
+let modules = pps :: [ "boot/types"; "boot/libs"; "boot/duneboot" ]
 let duneboot = ".duneboot"
 let prog = duneboot ^ ".exe"
 
@@ -40,6 +41,8 @@ let () =
   if not keep_generated_files
   then
     at_exit (fun () ->
+      (try Sys.remove "boot/pps.ml" with
+       | Sys_error _ -> ());
       Array.iter (Sys.readdir ".") ~f:(fun fn ->
         if
           String.length fn >= String.length duneboot
@@ -71,9 +74,9 @@ let read_file fn =
 
 let () =
   let v = Scanf.sscanf Sys.ocaml_version "%d.%d.%d" (fun a b c -> a, b, c) in
-  let compiler, which =
+  let compiler, ocamllex, which =
     if v >= min_supported_natively
-    then "ocamlc", None
+    then "ocamlc", "ocamllex", None
     else (
       let compiler = "ocamlfind -toolchain secondary ocamlc" in
       let output_fn, out = Filename.open_temp_file "duneboot" "ocamlfind-output" in
@@ -95,8 +98,10 @@ let () =
              a
              b);
         exit 2);
-      compiler, Some "--secondary")
+      let ocamllex = "ocamlfind -toolchain secondary ocamllex" in
+      compiler, ocamllex, Some "--secondary")
   in
+  exit_if_non_zero (runf "%s -q -o %s %s" ocamllex (pps ^ ".ml") (pps ^ ".mll"));
   exit_if_non_zero
     (runf
        "%s %s -intf-suffix .dummy -g -o %s -I boot %sunix.cma %s"

boot/dune

@@ -7,6 +7,8 @@
  (name runtest)
  (deps libs.ml))
 
+(ocamllex pps)
+
 (alias
  (name check)
  (deps libs.ml))

boot/duneboot.ml

@@ -609,24 +609,24 @@ module Io = struct
     | Ok s -> s
   ;;
 
-  let do_then_copy ~f a b =
+  let do_then_copy ~f ~pp a b =
     let s = read_file a in
     with_file_out b ~f:(fun oc ->
       f oc;
-      output_string oc s)
+      output_string oc (if pp then Pps.pp s else s))
   ;;
 
   (* copy a file - fails if the file exists *)
-  let copy a b = do_then_copy ~f:(fun _ -> ()) a b
+  let copy a b = do_then_copy ~pp:false ~f:(fun _ -> ()) a b
 
   (* copy a file and insert a header - fails if the file exists *)
-  let copy_with_header ~header a b =
-    do_then_copy ~f:(fun oc -> output_string oc header) a b
+  let copy_with_header ~pp ~header a b =
+    do_then_copy ~pp ~f:(fun oc -> output_string oc header) a b
   ;;
 
   (* copy a file and insert a directive - fails if the file exists *)
   let copy_with_directive ~directive a b =
-    do_then_copy ~f:(fun oc -> fprintf oc "#%s 1 %S\n" directive a) a b
+    do_then_copy ~pp:false ~f:(fun oc -> fprintf oc "#%s 1 %S\n" directive a) a b
   ;;
 
   let rec rm_rf fn =
@@ -1683,8 +1683,11 @@ module Library = struct
     | Header | C _ ->
       Io.copy_with_directive ~directive:"line" fn dst;
       Fiber.return [ mangled ]
-    | Ml { kind = `Ml | `Mli; _ } ->
-      Io.copy_with_header ~header fn dst;
+    | Ml { kind = `Mli; _ } ->
+      Io.copy_with_header ~pp:false ~header fn dst;
+      Fiber.return [ mangled ]
+    | Ml { kind = `Ml; _ } ->
+      Io.copy_with_header ~pp:true ~header fn dst;
       Fiber.return [ mangled ]
     | Ml { kind = `Mll; _ } -> copy_lexer fn dst ~header >>> Fiber.return [ mangled ]
     | Ml { kind = `Mly; _ } ->

boot/pps.mli

@@ -0,0 +1 @@
+val pp : string -> string

boot/pps.mll

@@ -0,0 +1,21 @@
+{
+  let b = Buffer.create 512
+}
+
+rule pp = parse
+ | "let%expect_test" { skip lexbuf }
+ | _ as c { Buffer.add_char b c; pp lexbuf }
+ | eof { () }
+
+and skip = parse
+  | ";;" { pp lexbuf }
+  | _ { skip lexbuf }
+  | eof { failwith "unterminated let%expect_test" }
+
+{
+  let pp s =
+    let lb = Lexing.from_string s in
+    Buffer.clear b;
+    pp lb;
+    Buffer.contents b
+}

src/dune_digest/dune

@@ -1,5 +1,8 @@
 (library
  (name dune_digest)
+ (preprocess
+  (pps ppx_expect))
+ (inline_tests)
  (libraries
   fiber
   dune_scheduler

src/dune_sexp/dune

@@ -1,6 +1,8 @@
 (library
  (name dune_sexp)
  (synopsis "[Internal] S-expression library")
+ (inline_tests)
+ (preprocess (pps ppx_expect))
  (libraries stdune uutf))
 
 (ocamllex lexer versioned_file_first_line)

src/dune_sexp/escape.ml

@@ -132,3 +132,162 @@ let quoted s =
   Bytes.unsafe_set s' (n + 1) '"';
   Bytes.unsafe_to_string s'
 ;;
+
+let%expect_test "escaped - plain strings pass through unchanged" =
+  let test s =
+    let r = escaped s in
+    Printf.printf "%S -> %S\n" s r
+  in
+  test "hello";
+  test "foo_bar";
+  test "123";
+  test "a/b/c";
+  [%expect
+    {|
+    "hello" -> "hello"
+    "foo_bar" -> "foo_bar"
+    "123" -> "123"
+    "a/b/c" -> "a/b/c"
+    |}]
+;;
+
+let%expect_test "escaped - special characters are escaped" =
+  let test s =
+    let r = escaped s in
+    Printf.printf "%S -> %S\n" s r
+  in
+  test "has\"quote";
+  test "back\\slash";
+  test "new\nline";
+  test "tab\there";
+  test "car\rret";
+  test "back\bspace";
+  [%expect
+    {|
+    "has\"quote" -> "has\\\"quote"
+    "back\\slash" -> "back\\\\slash"
+    "new\nline" -> "new\\nline"
+    "tab\there" -> "tab\\there"
+    "car\rret" -> "car\\rret"
+    "back\bspace" -> "back\\bspace"
+    |}]
+;;
+
+let%expect_test "escaped - percent brace escaping" =
+  let test s =
+    let r = escaped s in
+    Printf.printf "%S -> %S\n" s r
+  in
+  test "%{var}";
+  test "100%";
+  test "%%";
+  test "%alone";
+  [%expect
+    {|
+    "%{var}" -> "\\%{var}"
+    "100%" -> "100%"
+    "%%" -> "%%"
+    "%alone" -> "%alone"
+    |}]
+;;
+
+let%expect_test "escaped - empty string" =
+  let r = escaped "" in
+  Printf.printf "%S -> %S\n" "" r;
+  [%expect {| "" -> "" |}]
+;;
+
+let%expect_test "escaped - non-ascii bytes are octal-escaped" =
+  let test s =
+    let r = escaped s in
+    Printf.printf "%S -> %S\n" s r
+  in
+  test "\x00";
+  test "\x01";
+  test "\x7f";
+  test "\xff";
+  [%expect
+    {|
+    "\000" -> "\000"
+    "\001" -> "\001"
+    "\127" -> "\127"
+    "\255" -> "\\255"
+    |}]
+;;
+
+let%expect_test "escaped - valid utf8 passes through" =
+  let test s =
+    let r = escaped s in
+    Printf.printf "%S -> %S\n" s r
+  in
+  (* 2-byte: é *)
+  test "\xc3\xa9";
+  (* 3-byte: € *)
+  test "\xe2\x82\xac";
+  (* 4-byte: 𝄞 *)
+  test "\xf0\x9d\x84\x9e";
+  [%expect
+    {|
+    "\195\169" -> "\195\169"
+    "\226\130\172" -> "\226\130\172"
+    "\240\157\132\158" -> "\240\157\132\158"
+    |}]
+;;
+
+let%expect_test "quoted - wraps in double quotes" =
+  let test s =
+    let r = quoted s in
+    Printf.printf "%S -> %s\n" s r
+  in
+  test "";
+  test "hello";
+  test "has space";
+  test "has\"quote";
+  test "new\nline";
+  test "%{var}";
+  [%expect
+    {|
+    "" -> ""
+    "hello" -> "hello"
+    "has space" -> "has space"
+    "has\"quote" -> "has\"quote"
+    "new\nline" -> "new\nline"
+    "%{var}" -> "\%{var}"
+    |}]
+;;
+
+let%expect_test "quote_length - matches actual escaped length" =
+  let test s =
+    let ql = quote_length s in
+    let actual = String.length (escaped s) in
+    if ql <> actual
+    then Printf.printf "MISMATCH %S: quote_length=%d escaped_length=%d\n" s ql actual
+  in
+  test "";
+  test "hello";
+  test "has\"quote";
+  test "new\nline";
+  test "%{var}";
+  test "\x00\xff";
+  test "\xc3\xa9";
+  test "\xe2\x82\xac";
+  test "\xf0\x9d\x84\x9e";
+  print_endline "all match";
+  [%expect {| all match |}]
+;;
+
+let%expect_test "escaped - mixed content" =
+  let test s =
+    let r = escaped s in
+    Printf.printf "%S -> %S\n" s r
+  in
+  test "hello\nworld\t!";
+  test "say \"hi\" and \\go";
+  test "%{x} is 100%";
+  [%expect
+    {|
+    "hello\nworld\t!" -> "hello\\nworld\\t!"
+    "say \"hi\" and \\go" -> "say \\\"hi\\\" and \\\\go"
+    "%{x} is 100%" -> "\\%{x} is 100%"
+    |}]
+;;