diff --git a/CHANGELOG.md b/CHANGELOG.md index 0f667bae70..9ec2098e91 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 8bb6b8a363..407afb152b 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 5f751f4fda..4977770cf0 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 446de39f4d..56ac24bd1f 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 0000000000..00ceefd492 --- /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 00ceefd492..e096bce075 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 4c01311bb9..37a1d7e597 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;