Enforce string literal payload invariants

Signed-off-by: Christoph Knittel <ck@cca.io>

Author: cknitt

analysis/src/dump_ast.ml

@@ -45,8 +45,12 @@ let print_constant const =
   | Pconst_char {source; semantic} ->
     "Pconst_char(source=" ^ source ^ ", semantic=" ^ string_of_int semantic
     ^ ")"
-  | Pconst_string {source; semantic} ->
-    "Pconst_string(source=" ^ source ^ ", semantic=" ^ semantic ^ ")"
+  | Pconst_string payload ->
+    "Pconst_string(source="
+    ^ String_literal.source payload
+    ^ ", semantic="
+    ^ String_literal.semantic payload
+    ^ ")"
   | Pconst_json source -> "Pconst_json(" ^ source ^ ")"
   | Pconst_raw_source source -> "Pconst_raw_source(" ^ source ^ ")"
   | Pconst_float (s, _) -> "Pconst_float(" ^ s ^ ")"

compiler/core/j.ml

@@ -149,7 +149,7 @@ and expression_desc =
           longer needs to be preserved. For example, ["a\\n"] is stored with
           an actual newline and is emitted using the compiler's chosen quoting
           and escaping. *)
-  | Template_literal of {source: string; semantic: string}
+  | Template_literal of Asttypes.template_segment
       (** A non-interpolated ordinary backquoted literal. For [`a\n`], [source]
           is ["a\\n"] and [semantic] contains an actual newline. [source] is
           used for JavaScript emission; [semantic] is used for comparisons and

compiler/core/js_analyzer.ml

@@ -229,10 +229,9 @@ let rec eq_expression ({expression_desc = x0} : J.expression)
     match y0 with
     | Str a1 -> a0 = a1
     | _ -> false)
-  | Template_literal {source = source0; semantic = semantic0} -> (
+  | Template_literal segment0 -> (
     match y0 with
-    | Template_literal {source = source1; semantic = semantic1} ->
-      source0 = source1 && semantic0 = semantic1
+    | Template_literal segment1 -> segment0 = segment1
     | _ -> false)
   | Static_index (e0, p0, off0) -> (
     match y0 with

compiler/core/js_dump.ml

@@ -710,11 +710,11 @@ and expression_desc cxt ~(level : int) f x : cxt =
     P.string f "`";
     let rec print_segments cxt segments values =
       match (segments, values) with
-      | [({source} : Asttypes.template_segment)], [] ->
-        P.string f source;
+      | [segment], [] ->
+        P.string f (String_literal.source segment);
         cxt
-      | ({source} : Asttypes.template_segment) :: segments, value :: values ->
-        P.string f source;
+      | segment :: segments, value :: values ->
+        P.string f (String_literal.source segment);
         P.string f "${";
         let cxt = expression cxt ~level:0 f value in
         P.string f "}";
@@ -734,8 +734,8 @@ and expression_desc cxt ~(level : int) f x : cxt =
   | Str txt ->
     Js_dump_string.pp_string f txt;
     cxt
-  | Template_literal {source} ->
-    P.string f ("`" ^ source ^ "`");
+  | Template_literal segment ->
+    P.string f ("`" ^ String_literal.source segment ^ "`");
     cxt
   | Json_literal source ->
     P.string f source;

compiler/core/js_exp_make.ml

@@ -81,43 +81,35 @@ let interpolated_template ?comment segments values : t =
     if value.comment <> None then None
     else
       match value.expression_desc with
-      | Str semantic ->
-        Some
-          ({source = String_literal.encode_js_template semantic; semantic}
-            : Asttypes.template_segment)
-      | Template_literal {source; semantic} ->
-        Some ({source; semantic} : Asttypes.template_segment)
+      | Str semantic -> Some (String_literal.template_from_semantic semantic)
+      | Template_literal segment -> Some segment
       | _ -> None
   in
-  let rec merge rev_segments rev_values
-      (segments : Asttypes.template_segment list) values =
+  let rec merge rev_segments rev_values rev_parts segments values =
     match (segments, values) with
-    | [segment], [] -> (List.rev (segment :: rev_segments), List.rev rev_values)
-    | segment :: next_segment :: rest, value :: values -> (
+    | [], [] ->
+      let segment = String_literal.concat_template (List.rev rev_parts) in
+      (List.rev (segment :: rev_segments), List.rev rev_values)
+    | next_segment :: rest, value :: values -> (
       match literal_segment value with
       | Some literal ->
-        let semantic =
-          segment.semantic ^ literal.semantic ^ next_segment.semantic
-        in
-        let preserved_source =
-          segment.source ^ literal.source ^ next_segment.source
-        in
-        let source =
-          match String_literal.decode_js_template_escapes preserved_source with
-          | Some decoded when decoded = semantic -> preserved_source
-          | _ -> String_literal.encode_js_template semantic
-        in
-        let merged : Asttypes.template_segment = {source; semantic} in
-        merge rev_segments rev_values (merged :: rest) values
+        merge rev_segments rev_values
+          (next_segment :: literal :: rev_parts)
+          rest values
       | None ->
-        merge (segment :: rev_segments) (value :: rev_values)
-          (next_segment :: rest) values)
+        let segment = String_literal.concat_template (List.rev rev_parts) in
+        merge (segment :: rev_segments) (value :: rev_values) [next_segment]
+          rest values)
     | _ -> assert false
   in
-  let segments, values = merge [] [] segments values in
+  let segments, values =
+    match segments with
+    | segment :: segments -> merge [] [] [segment] segments values
+    | [] -> assert false
+  in
   let expression_desc =
     match (segments, values) with
-    | [{source; semantic}], [] -> J.Template_literal {source; semantic}
+    | [segment], [] -> J.Template_literal segment
     | _ -> J.Interpolated_template {segments; values}
   in
   {expression_desc; comment; source_loc = None}
@@ -206,12 +198,8 @@ let pure_runtime_call module_name fn_name args =
 let str ?comment txt : t =
   {expression_desc = Str txt; comment; source_loc = None}
 
-let template_literal ?comment ~semantic source : t =
-  {
-    expression_desc = Template_literal {source; semantic};
-    comment;
-    source_loc = None;
-  }
+let template_literal ?comment segment : t =
+  {expression_desc = Template_literal segment; comment; source_loc = None}
 
 let json_literal ?comment source : t =
   {expression_desc = Json_literal source; comment; source_loc = None}
@@ -692,7 +680,8 @@ let array_length ?comment (e : t) : t =
 
 let string_literal_semantic (e : t) =
   match e.expression_desc with
-  | Str semantic | Template_literal {semantic} -> Some semantic
+  | Str semantic -> Some semantic
+  | Template_literal segment -> Some (String_literal.semantic segment)
   | _ -> None
 
 let string_length ?comment (e : t) : t =

compiler/core/js_exp_make.mli

@@ -81,7 +81,7 @@ val runtime_call :
 
 val str : ?comment:string -> string -> t
 
-val template_literal : ?comment:string -> semantic:string -> string -> t
+val template_literal : ?comment:string -> Asttypes.template_segment -> t
 
 val json_literal : ?comment:string -> string -> t
 

compiler/core/lam_compile_primitive.ml

@@ -85,8 +85,7 @@ let translate output_prefix loc (cxt : Lam_compile_context.t)
     match args with
     | fn :: values -> E.tagged_template fn strings values
     | [] -> assert false)
-  | Ptemplate [{source; semantic}] when args = [] ->
-    E.template_literal ~semantic source
+  | Ptemplate [segment] when args = [] -> E.template_literal segment
   | Ptemplate segments -> E.interpolated_template segments args
   | Pnull_to_opt -> (
     match args with

compiler/ml/ast_helper.ml

@@ -47,7 +47,7 @@ module Const = struct
     let semantic = Char.code c in
     Pconst_char {source = String_literal.encode_char_source semantic; semantic}
   let string semantic =
-    Pconst_string {source = String_literal.encode_js_string semantic; semantic}
+    Pconst_string (String_literal.string_from_semantic semantic)
 end
 
 module Typ = struct

compiler/ml/ast_mapper.ml

@@ -655,7 +655,8 @@ module Ppx_context = struct
   let restore fields =
     let field name payload =
       let rec get_string = function
-        | {pexp_desc = Pexp_constant (Pconst_string {semantic})} -> semantic
+        | {pexp_desc = Pexp_constant (Pconst_string payload)} ->
+          String_literal.semantic payload
         | _ ->
           raise_errorf
             "Internal error: invalid [@@@ocaml.ppx.context { %s }] string \

compiler/ml/ast_mapper_from0.ml

@@ -117,10 +117,12 @@ let normalize_ppx_semantic_string semantic =
 
 let semantic_string semantic =
   let semantic = normalize_ppx_semantic_string semantic in
-  Pt.Pconst_string {source = String_literal.encode_js_string semantic; semantic}
+  Pt.Pconst_string (String_literal.string_from_semantic semantic)
 
 let source_string ~loc source =
-  Pt.Pconst_string {source; semantic = decode_js_string ~loc source}
+  match String_literal.string_from_source source with
+  | Some payload -> Pt.Pconst_string payload
+  | None -> Location.raise_errorf ~loc "Invalid string escape sequence"
 
 let template_source_from0 = function
   | source, Some ("js" | "*j") -> source