Repository: rescript-lang/rescript
Pull request #7435: Handle non-printable control characters when escaping JSON
Author: login: mediremi
Created: 2025-05-06T14:34:12Z | Merged: 2025-05-07T19:28:37Z

When the VS Code extension calls `rescript-editor-analysis`, it replies with JSON serialised by [analysis/vendor/json/Json.ml](https://github.com/rescript-lang/rescript/blob/master/analysis/vendor/json/Json.ml).

While `Json.escape` escapes printable characters correctly, it did not handle non-printable control characters (i.e. characters with a char code < 0x20). This meant that JSON sent to VS code was not always escaped properly and prevented code actions from being available in certain situations.

For example, opening up https://github.com/rescript-lang/rescript-lang.org/blob/master/src/bindings/RescriptCompilerApi.res in VS Code currently results in `SyntaxError: Bad control character in string literal in JSON at position 1319 (line 15 column 751)`:

![image](https://github.com/user-attachments/assets/aab07072-6542-48ee-af08-d9ce81c1a91f)

In the example above, this is caused by `Warning.toCompactErrorLine` containing a string with control character `0x27`.

With the escaping logic I've added, this issue no longer occurs.

# Changes I've made
- Handled control characters in `analysis/vendor/json/Json.ml`
- Renamed `tests/ounit_tests/ounit_json_tests.ml` to `tests/ounit_tests/ounit_ext_json_tests.ml`
- Created a `tests/ounit_tests/ounit_json_tests.ml` test suite for `analysis/vendor/json/Json.ml`
- Handled control characters in `compiler/ext/ext_json_noloc.ml`, which is used by the bsb watcher

# Future work
- `analysis/vendor/json/Json.ml` and `compiler/ext/ext_json` should probably be eventually replaced with [Yojson](https://github.com/ocaml-community/yojson)


Diff:
diff --git a/CHANGELOG.md b/CHANGELOG.md
index 0f667bae706..9ec2098e91a 100644
--- a/CHANGELOG.md
+++ b/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
 
diff --git a/analysis/vendor/json/Json.ml b/analysis/vendor/json/Json.ml
index 8bb6b8a363a..407afb152bd 100644
--- a/analysis/vendor/json/Json.ml
+++ b/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;
diff --git a/compiler/ext/ext_json_noloc.ml b/compiler/ext/ext_json_noloc.ml
index 5f751f4fdaf..4977770cf06 100644
--- a/compiler/ext/ext_json_noloc.ml
+++ b/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 ^ "\""
 
diff --git a/tests/ounit_tests/dune b/tests/ounit_tests/dune
index 446de39f4df..56ac24bd1fd 100644
--- a/tests/ounit_tests/dune
+++ b/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))
diff --git a/tests/ounit_tests/ounit_ext_json_tests.ml b/tests/ounit_tests/ounit_ext_json_tests.ml
new file mode 100644
index 00000000000..00ceefd492a
--- /dev/null
+++ b/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 );
+       ]
diff --git a/tests/ounit_tests/ounit_json_tests.ml b/tests/ounit_tests/ounit_json_tests.ml
index 00ceefd492a..e096bce0757 100644
--- a/tests/ounit_tests/ounit_json_tests.ml
+++ b/tests/ounit_tests/ounit_json_tests.ml
@@ -1,153 +1,14 @@
 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 );
+         ( "escape 'hello'" >:: fun _ ->
+           let escaped = Json.escape "hello" in
+           let expected = "hello" in
+           OUnit.assert_equal escaped expected );
+         ( "escape \\x17" >:: fun _ ->
+           let escaped = Json.escape "\x17" in
+           let expected = "\\u0017" in
+           OUnit.assert_equal escaped expected );
        ]
diff --git a/tests/ounit_tests/ounit_tests_main.ml b/tests/ounit_tests/ounit_tests_main.ml
index 4c01311bb97..37a1d7e597b 100644
--- a/tests/ounit_tests/ounit_tests_main.ml
+++ b/tests/ounit_tests/ounit_tests_main.ml
@@ -3,6 +3,7 @@ let suites =
     [
       Ounit_vec_test.suites;
       Ounit_json_tests.suites;
+      Ounit_ext_json_tests.suites;
       Ounit_path_tests.suites;
       Ounit_array_tests.suites;
       Ounit_scc_tests.suites;


Reviews:
user: login: mediremi
state: COMMENTED
author_association: MEMBER
submitted_at: 2025-05-06T14:36:13Z
user: login: mediremi
state: COMMENTED
author_association: MEMBER
submitted_at: 2025-05-06T14:36:46Z
user: login: nojaf
state: COMMENTED
author_association: MEMBER
submitted_at: 2025-05-06T15:05:27Z
user: login: cometkim
state: COMMENTED
author_association: MEMBER
submitted_at: 2025-05-07T00:15:27Z
user: login: zth
body: This is looking good to me, thank you! @cristianoc any thoughts?
state: APPROVED
author_association: MEMBER
submitted_at: 2025-05-07T11:07:21Z

Review comments:
diff_hunk: @@ -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 ->
path: analysis/vendor/json/Json.ml
user: login: mediremi
body: I think this module and `compiler/ext/ext_json` should probably be eventually replaced with [Yojson](https://github.com/ocaml-community/yojson)
created_at: 2025-05-06T14:36:13Z
author_association: MEMBER
diff_hunk: @@ -1,153 +1,14 @@
 let ( >:: ), ( >::: ) = OUnit.(( >:: ), ( >::: ))
-type t = Ext_json_noloc.t
path: tests/ounit_tests/ounit_json_tests.ml
user: login: mediremi
body: The existing `Ext_json` tests were moved to `tests/ounit_tests/ounit_ext_json_tests.ml`
created_at: 2025-05-06T14:36:46Z
author_association: MEMBER
diff_hunk: @@ -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 ->
path: analysis/vendor/json/Json.ml
user: login: nojaf
body: @cometkim 😉
created_at: 2025-05-06T15:05:27Z
author_association: MEMBER
diff_hunk: @@ -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 ->
path: analysis/vendor/json/Json.ml
user: login: cometkim
body: 😅

Already work on it in my local branch. There is too much stuff to clean up
created_at: 2025-05-07T00:15:27Z
author_association: MEMBER

PR comments:
user: login: pkg-pr-new[bot]
created_at: 2025-05-06T14:44:48Z
body: 
[Open in StackBlitz](https://pkg.pr.new/template/bf7e8337-e981-46e0-877d-ea5f799a9ce9)


<details><summary><b>rescript</b></summary><p>

```
npm i https://pkg.pr.new/rescript-lang/rescript@7435
```

</p></details>
      
    

<details><summary><b>@rescript/darwin-arm64</b></summary><p>

```
npm i https://pkg.pr.new/rescript-lang/rescript/@rescript/darwin-arm64@7435
```

</p></details>
      
    

<details><summary><b>@rescript/darwin-x64</b></summary><p>

```
npm i https://pkg.pr.new/rescript-lang/rescript/@rescript/darwin-x64@7435
```

</p></details>
      
    

<details><summary><b>@rescript/linux-arm64</b></summary><p>

```
npm i https://pkg.pr.new/rescript-lang/rescript/@rescript/linux-arm64@7435
```

</p></details>
      
    

<details><summary><b>@rescript/linux-x64</b></summary><p>

```
npm i https://pkg.pr.new/rescript-lang/rescript/@rescript/linux-x64@7435
```

</p></details>
      
    

<details><summary><b>@rescript/win32-x64</b></summary><p>

```
npm i https://pkg.pr.new/rescript-lang/rescript/@rescript/win32-x64@7435
```

</p></details>
      
    

_commit: <a href="https://github.com/rescript-lang/rescript/runs/41731273905"><code>3c376bc</code></a>_

author_association: NONE
user: login: cristianoc
created_at: 2025-05-07T14:19:19Z
body: > This is looking good to me, thank you! @cristianoc any thoughts?

Looks great!
author_association: COLLABORATOR