Handle non-printable control characters when escaping JSON

CHANGELOG.md

@@ -30,6 +30,7 @@
 - Fix broken `bstracing` CLI location. https://github.com/rescript-lang/rescript/pull/7398
 - Fix field flattening optimization to avoid creating unnecessary copies of allocating constants. https://github.com/rescript-lang/rescript-compiler/pull/7421
 - Fix leading comments removed when braces inside JSX contains `let` assignment. https://github.com/rescript-lang/rescript/pull/7424
+- Fix JSON escaping in code editor analysis: JSON was not always escaped properly, which prevented code actions from being available in certain situations https://github.com/rescript-lang/rescript/pull/7435
 
 #### :house: Internal
 

analysis/vendor/json/Json.ml

@@ -141,7 +141,10 @@ let escape text =
       | '\b' -> Buffer.add_string buf "\\b"
       | '\r' -> Buffer.add_string buf "\\r"
       | '\t' -> Buffer.add_string buf "\\t"
-      | c -> Buffer.add_char buf c);
+      | c ->
+        let code = Char.code c in
+        if code < 0x20 then Printf.bprintf buf "\\u%04x" code
+        else Buffer.add_char buf c);
       loop (i + 1))
   in
   loop 0;

compiler/ext/ext_json_noloc.ml

@@ -33,48 +33,27 @@ type t =
   | Obj of t Map_string.t
 
 (** poor man's serialization *)
-let naive_escaped (unmodified_input : string) : string =
-  let n = ref 0 in
-  let len = String.length unmodified_input in
-  for i = 0 to len - 1 do
-    n :=
-      !n
-      +
-      match String.unsafe_get unmodified_input i with
-      | '\"' | '\\' | '\n' | '\t' | '\r' | '\b' -> 2
-      | _ -> 1
-  done;
-  if !n = len then unmodified_input
-  else
-    let result = Bytes.create !n in
-    n := 0;
-    for i = 0 to len - 1 do
-      let open Bytes in
-      (match String.unsafe_get unmodified_input i with
-      | ('\"' | '\\') as c ->
-        unsafe_set result !n '\\';
-        incr n;
-        unsafe_set result !n c
-      | '\n' ->
-        unsafe_set result !n '\\';
-        incr n;
-        unsafe_set result !n 'n'
-      | '\t' ->
-        unsafe_set result !n '\\';
-        incr n;
-        unsafe_set result !n 't'
-      | '\r' ->
-        unsafe_set result !n '\\';
-        incr n;
-        unsafe_set result !n 'r'
-      | '\b' ->
-        unsafe_set result !n '\\';
-        incr n;
-        unsafe_set result !n 'b'
-      | c -> unsafe_set result !n c);
-      incr n
-    done;
-    Bytes.unsafe_to_string result
+let naive_escaped (text : string) : string =
+  let ln = String.length text in
+  let buf = Buffer.create ln in
+  let rec loop i =
+    if i < ln then (
+      (match text.[i] with
+      | '\012' -> Buffer.add_string buf "\\f"
+      | '\\' -> Buffer.add_string buf "\\\\"
+      | '"' -> Buffer.add_string buf "\\\""
+      | '\n' -> Buffer.add_string buf "\\n"
+      | '\b' -> Buffer.add_string buf "\\b"
+      | '\r' -> Buffer.add_string buf "\\r"
+      | '\t' -> Buffer.add_string buf "\\t"
+      | c ->
+        let code = Char.code c in
+        if code < 0x20 then Printf.bprintf buf "\\u%04x" code
+        else Buffer.add_char buf c);
+      loop (i + 1))
+  in
+  loop 0;
+  Buffer.contents buf
 
 let quot x = "\"" ^ naive_escaped x ^ "\""
 

tests/ounit_tests/dune

@@ -11,4 +11,4 @@
   (<> %{profile} browser))
  (flags
   (:standard -w +a-4-9-30-40-41-42-48-70))
- (libraries bsb bsb_helper core ounit2))
+ (libraries bsb bsb_helper core ounit2 analysis))

tests/ounit_tests/ounit_ext_json_tests.ml

@@ -0,0 +1,153 @@
+let ( >:: ), ( >::: ) = OUnit.(( >:: ), ( >::: ))
+type t = Ext_json_noloc.t
+let rec equal (x : t) (y : t) =
+  match x with
+  | Null -> (
+    (* [%p? Null _ ] *)
+    match y with
+    | Null -> true
+    | _ -> false)
+  | Str str -> (
+    match y with
+    | Str str2 -> str = str2
+    | _ -> false)
+  | Flo flo -> (
+    match y with
+    | Flo flo2 -> flo = flo2
+    | _ -> false)
+  | True -> (
+    match y with
+    | True -> true
+    | _ -> false)
+  | False -> (
+    match y with
+    | False -> true
+    | _ -> false)
+  | Arr content -> (
+    match y with
+    | Arr content2 -> Ext_array.for_all2_no_exn content content2 equal
+    | _ -> false)
+  | Obj map -> (
+    match y with
+    | Obj map2 ->
+      let xs =
+        Map_string.bindings map |> List.sort (fun (a, _) (b, _) -> compare a b)
+      in
+      let ys =
+        Map_string.bindings map2 |> List.sort (fun (a, _) (b, _) -> compare a b)
+      in
+      Ext_list.for_all2_no_exn xs ys (fun (k0, v0) (k1, v1) ->
+          k0 = k1 && equal v0 v1)
+    | _ -> false)
+
+open Ext_json_parse
+let ( |? ) m (key, cb) = m |> Ext_json.test key cb
+
+let rec strip (x : Ext_json_types.t) : Ext_json_noloc.t =
+  let open Ext_json_noloc in
+  match x with
+  | True _ -> true_
+  | False _ -> false_
+  | Null _ -> null
+  | Flo {flo = s} -> flo s
+  | Str {str = s} -> str s
+  | Arr {content} -> arr (Array.map strip content)
+  | Obj {map} -> obj (Map_string.map map strip)
+
+let id_parsing_serializing x =
+  let normal_s =
+    Ext_json_noloc.to_string @@ strip @@ Ext_json_parse.parse_json_from_string x
+  in
+  let normal_ss =
+    Ext_json_noloc.to_string @@ strip
+    @@ Ext_json_parse.parse_json_from_string normal_s
+  in
+  if normal_s <> normal_ss then (
+    prerr_endline "ERROR";
+    prerr_endline normal_s;
+    prerr_endline normal_ss);
+  OUnit.assert_equal ~cmp:(fun (x : string) y -> x = y) normal_s normal_ss
+
+let id_parsing_x2 x =
+  let stru = Ext_json_parse.parse_json_from_string x |> strip in
+  let normal_s = Ext_json_noloc.to_string stru in
+  let normal_ss = strip (Ext_json_parse.parse_json_from_string normal_s) in
+  if equal stru normal_ss then true
+  else (
+    prerr_endline "ERROR";
+    prerr_endline normal_s;
+    Format.fprintf Format.err_formatter "%a@.%a@." Ext_obj.pp_any stru
+      Ext_obj.pp_any normal_ss;
+
+    prerr_endline (Ext_json_noloc.to_string normal_ss);
+    false)
+
+let test_data =
+  [
+    {|
+      {}
+      |};
+    {| [] |};
+    {| [1,2,3]|};
+    {| ["x", "y", 1,2,3 ]|};
+    {| { "x" :  3, "y" : "x", "z" : [1,2,3, "x"] }|};
+    {| {"x " : true , "y" : false , "z\"" : 1} |};
+  ]
+exception Parse_error
+let suites =
+  __FILE__
+  >::: [
+         (__LOC__ >:: fun _ -> List.iter id_parsing_serializing test_data);
+         ( __LOC__ >:: fun _ ->
+           List.iteri
+             (fun i x ->
+               OUnit.assert_bool (__LOC__ ^ string_of_int i) (id_parsing_x2 x))
+             test_data );
+         ( "empty_json" >:: fun _ ->
+           let v = parse_json_from_string "{}" in
+           match v with
+           | Obj {map = v} -> OUnit.assert_equal (Map_string.is_empty v) true
+           | _ -> OUnit.assert_failure "should be empty" );
+         ( "empty_arr" >:: fun _ ->
+           let v = parse_json_from_string "[]" in
+           match v with
+           | Arr {content = [||]} -> ()
+           | _ -> OUnit.assert_failure "should be empty" );
+         ( "empty trails" >:: fun _ ->
+           ( OUnit.assert_raises Parse_error @@ fun _ ->
+             try parse_json_from_string {| [,]|} with _ -> raise Parse_error );
+           OUnit.assert_raises Parse_error @@ fun _ ->
+           try parse_json_from_string {| {,}|} with _ -> raise Parse_error );
+         ( "two trails" >:: fun _ ->
+           ( OUnit.assert_raises Parse_error @@ fun _ ->
+             try parse_json_from_string {| [1,2,,]|}
+             with _ -> raise Parse_error );
+           OUnit.assert_raises Parse_error @@ fun _ ->
+           try parse_json_from_string {| { "x": 3, ,}|}
+           with _ -> raise Parse_error );
+         ( "two trails fail" >:: fun _ ->
+           OUnit.assert_raises Parse_error @@ fun _ ->
+           try parse_json_from_string {| { "x": 3, 2 ,}|}
+           with _ -> raise Parse_error );
+         ( "trail comma obj" >:: fun _ ->
+           let v = parse_json_from_string {| { "x" : 3 , }|} in
+           let v1 = parse_json_from_string {| { "x" : 3 , }|} in
+           let test (v : Ext_json_types.t) =
+             match v with
+             | Obj {map = v} ->
+               v |? ("x", `Flo (fun x -> OUnit.assert_equal x "3")) |> ignore
+             | _ -> OUnit.assert_failure "trail comma"
+           in
+           test v;
+           test v1 );
+         ( "trail comma arr" >:: fun _ ->
+           let v = parse_json_from_string {| [ 1, 3, ]|} in
+           let v1 = parse_json_from_string {| [ 1, 3 ]|} in
+           let test (v : Ext_json_types.t) =
+             match v with
+             | Arr {content = [|Flo {flo = "1"}; Flo {flo = "3"}|]} -> ()
+             | _ -> OUnit.assert_failure "trailing comma array"
+           in
+           test v;
+           test v1 );
+       ]