Fix bug in format of sourceContents field, cleaner interface

Author: OlivierNicole

compiler/bin-js_of_ocaml/cmd_arg.ml

@@ -321,7 +321,7 @@ let options =
             ; sources_contents =
                 (if sourcemap_don't_inline_content
                  then None
-                 else Some (Source_map.Sources_contents.encode []))
+                 else Some [])
             ; names = []
             ; mappings = Source_map.Mappings.empty
             } )
@@ -563,7 +563,7 @@ let options_runtime_only =
             ; sources_contents =
                 (if sourcemap_don't_inline_content
                  then None
-                 else Some (Source_map.Sources_contents.encode []))
+                 else Some [])
             ; names = []
             ; mappings = Source_map.Mappings.empty
             } )

compiler/bin-js_of_ocaml/link.ml

@@ -106,7 +106,7 @@ let options =
             ; file
             ; sourceroot = sourcemap_root
             ; sources = []
-            ; sources_contents = Some (Source_map.Sources_contents.encode [])
+            ; sources_contents = Some []
             ; names = []
             ; mappings = Source_map.Mappings.empty
             } )

compiler/lib/js_output.ml

@@ -1926,7 +1926,7 @@ let program ?(accept_unnamed_var = false) f ?source_map p =
                 loop xs ys
           in
           let sources_contents =
-            Option.map ~f:Source_map.Sources_contents.decode sm.sources_contents
+            Option.map ~f:(List.map ~f:Source_map.Source_text.decode) sm.sources_contents
           in
           loop sm.sources (Option.value ~default:[] sources_contents);
           List.iter sm.Source_map.names ~f:(fun f ->
@@ -1985,7 +1985,7 @@ let program ?(accept_unnamed_var = false) f ?source_map p =
         let sources_contents =
           let open Option.Syntax in
           let* r = contents in
-          Option.return (Source_map.Sources_contents.encode (List.rev !r))
+          Option.return (List.map ~f:Source_map.Source_text.encode (List.rev !r))
         in
         let sources =
           List.map sources ~f:(fun filename ->

compiler/lib/link_js.ml

@@ -470,10 +470,7 @@ let link ~output ~linkall ~mklib ~toplevel ~files ~resolve_sourcemap_url ~source
       in
       let merged_sourcemap =
         let open Source_map in
-        assert (
-          match init_sm.mappings with
-          | Uninterpreted "" -> true
-          | _ -> false);
+        assert (String.equal (Mappings.to_string init_sm.mappings) "");
         { version = init_sm.version
         ; file = init_sm.file
         ; Index.sections =

compiler/lib/source_map.ml

@@ -58,27 +58,14 @@ module Line_edits = struct
   let pp fmt = Format.(pp_print_list pp_action fmt)
 end
 
-module Mappings : sig
-  type t = private Uninterpreted of string [@@unboxed]
-
-  external uninterpreted : string -> t = "%identity"
-
-  val empty : t
-
-  val decode : t -> map list
-
-  val encode : map list -> t
-
-  val edit : strict:bool -> t -> Line_edits.t -> t
-
-  (* Not for export *)
-  val concat : source_count1:int -> name_count1:int -> t -> t -> t
-end = struct
+module Mappings = struct
   type t = Uninterpreted of string [@@unboxed]
 
   let empty = Uninterpreted ""
 
-  external uninterpreted : string -> t = "%identity"
+  external of_string : string -> t = "%identity"
+
+  external to_string : t -> string = "%identity"
 
   let update_carries_from_segment
       ~carry_source
@@ -573,71 +560,43 @@ end = struct
     readline 1 0 []
 end
 
-module Sources_contents : sig
-  type t = private Uninterpreted of string [@@unboxed]
+module Source_text = struct
+  type t = Uninterpreted of string [@@unboxed]
 
-  external uninterpreted : string -> t = "%identity"
+  external of_json_string : string -> t = "%identity"
 
-  val decode : t -> string option list
+  external to_json_string : t -> string = "%identity"
+  
+  let to_json =
+    function
+    | None -> `Null
+    | Some text -> `String text
 
-  val encode : string option list -> t
-end = struct
-  type t = Uninterpreted of string [@@unboxed]
+  let encode t =
+    let json = Yojson.Basic.to_string (to_json t) in
+    Uninterpreted json
 
-  external uninterpreted : string -> t = "%identity"
-
-  let to_json (cs : string option list) =
-    `List
-      (List.map
-         ~f:(function
-           | None -> `Null
-           | Some s -> `String s)
-         cs)
-
-  let encode cs =
-    (* There are two stages to the encoding. First encoding the list as a JSON
-       array of strings... *)
-    let array = Yojson.Basic.to_string (to_json cs) in
-    (* ... and then reifying that array itself as a string, under the form of a
-       JSON string literal. *)
-    let reified = Yojson.Basic.to_string (`String array) in
-    Uninterpreted reified
-
-  let of_json json =
-    match json with
-    | `List l ->
-        List.map
-          ~f:(function
-            | `String s -> Some s
-            | `Null -> None
-            | _ -> invalid_arg "Source_map.Sources_contents.of_json")
-          l
-    | _ -> invalid_arg "Source_map.Sources_contents.of_json"
-
-  let decode (Uninterpreted s) : string option list =
+  let of_json =
+    function
+    | `String s -> Some s
+    | `Null -> None
+    | _ -> invalid_arg "Source_map.Sources_contents.of_json: expected string or null"
+
+  let decode (Uninterpreted s) : string option =
     (* The two stages of the encoding, in reverse. *)
-    match Yojson.Basic.from_string s with
-    | `String array -> (
-        try of_json (Yojson.Basic.from_string array)
-        with Yojson.Json_error s ->
-          invalid_arg
-            ("Source_map.Sources_contents.decode: This is a valid JSON literal, but it \
-              does not encode a JSON array: "
-            ^ s))
-    | _ ->
-        invalid_arg
-          "Source_map.Sources_contents.decode: This is a valid JSON object but not a \
-           string literal"
-    | exception Yojson.Json_error s ->
-        invalid_arg ("Source_map.Sources_contents.decode: not a JSON string literal: " ^ s)
+    try of_json (Yojson.Basic.from_string s) with
+    | Yojson.Json_error s ->
+      invalid_arg
+        ("Source_map.Sources_contents.decode: This is not a valid JSON object: "
+        ^ s)
 end
 
 type t =
   { version : int
   ; file : string
   ; sourceroot : string option
   ; sources : string list
-  ; sources_contents : Sources_contents.t option
+  ; sources_contents : Source_text.t list option
   ; names : string list
   ; mappings : Mappings.t
   }
@@ -662,10 +621,7 @@ let concat ~file ~sourceroot s1 s2 =
   ; sources_contents =
       (match s1.sources_contents, s2.sources_contents with
       | None, contents | contents, None -> contents
-      | Some c1, Some c2 ->
-          let c1 = Sources_contents.decode c1 in
-          let c2 = Sources_contents.decode c2 in
-          Some (Sources_contents.encode (c1 @ c2)))
+      | Some c1, Some c2 -> Some (c1 @ c2))
   ; names = s1.names @ s2.names
   ; mappings =
       Mappings.concat

compiler/lib/source_map.mli

@@ -52,52 +52,53 @@ module Line_edits : sig
 end
 
 module Mappings : sig
-  (** Left uninterpreted, since many operations can be performed efficiently directly
-      on the encoded form. Instances of [t] produced by {!val:encode} are
-      guaranteed to be valid JSON string literals (surrounding double quotes
-      included). *)
-  type t = private Uninterpreted of string [@@unboxed]
+  type t
 
   val empty : t
   (** Represents the empty mapping. *)
 
-  external uninterpreted : string -> t = "%identity"
-  (** Create a value of type {!type:t} from a string, without attempting to
-      decode it. *)
+  val of_string : string -> t
+  (** By default, mappings are left uninterpreted, since many operations can be
+      performed efficiently directly on the encoded form. It is guaranteed that
+      {!val:of_string} and {!val:to_string} are inverse functions. *)
 
   val decode : t -> map list
 
   val encode : map list -> t
 
+  val to_string : t -> string
+  (** Returns the mappings as a string in the Source map v3 format. *)
+
   val edit : strict:bool -> t -> Line_edits.t -> t
   (** Apply line edits in order. If the number of {!const:Line_edits.Keep} and
       {!const:Line_edits.Drop} actions does not match the number of lines in
       the domain of the input mapping, only the lines affected by an edit are
       included in the result. *)
 end
 
-module Sources_contents : sig
-  (** Left uninterpreted by default as decoding this field can be costly if the
-      amount of code is large, and is seldom required. Instances of [t]
-      produced by {!val:encode} are guaranteed to be valid JSON string
-      literals (surrounding double quotes included). *)
-  type t = private Uninterpreted of string [@@unboxed]
+module Source_text : sig
+  type t
+
+  val of_json_string : string -> t
+  (** By default, sources contents are left uninterpreted as decoding this field can be
+      costly if the amount of code is large, and is seldom required. It is guaranteed that
+      {!val:of_json_string} and {!val:to_json_string} are inverse functions.  *)
 
-  external uninterpreted : string -> t = "%identity"
-  (** Create a value of type {!type:t} from a string, without attempting to
-      decode it. *)
+  val decode : t -> string option
 
-  val decode : t -> string option list
+  val encode : string option -> t
 
-  val encode : string option list -> t
+  val to_json_string : t -> string
+  (** Returns a valid JSON object (in this instance, a string literal, double quotes
+      included) representing the source text. *)
 end
 
 type t =
   { version : int
   ; file : string
   ; sourceroot : string option
   ; sources : string list
-  ; sources_contents : Sources_contents.t option
+  ; sources_contents : Source_text.t list option
         (** Left uninterpreted by default, since decoding it requires to handle special
           characters, which can be costly for huge codebases. *)
   ; names : string list
@@ -113,10 +114,7 @@ val concat : file:string -> sourceroot:string option -> t -> t -> t
 (** If [s1] encodes a mapping for a generated file [f1], and [s2] for a
     generated file [f2], then [concat ~file ~sourceroot s1 s2] encodes the
     union of these mappings for the concatenation of [f1] and [f2], with name
-    [file] and source root [sourceroot). Note that at the moment, this function
-    can be slow when the [sources_contents] field contains very large
-    codebases, as it decodes the whole source text. This may be fixed in the
-    future. *)
+    [file] and source root [sourceroot). *)
 
 module Index : sig
   type offset =

compiler/lib/source_map_io.yojson.ml

@@ -31,7 +31,9 @@ let rewrite_path path =
 let stringlit_of_string s = `Stringlit (Yojson.Basic.to_string (`String s))
 
 let json t =
-  let (Source_map.Mappings.Uninterpreted mappings) = t.mappings in
+  let mappings =
+    `Stringlit ("\"" ^ Mappings.to_string t.mappings ^ "\"") (* Nothing to escape *)
+  in
   let fields =
     [ "version", `Intlit (Int.to_string t.version)
     ; "file", stringlit_of_string (rewrite_path t.file)
@@ -43,18 +45,17 @@ let json t =
     ; "names", `List (List.map (fun s -> stringlit_of_string s) t.names)
     ; ( "sources"
       , `List (List.map (fun s -> stringlit_of_string (rewrite_path s)) t.sources) )
-    ; "mappings", `Stringlit ("\"" ^ mappings ^ "\"") (* Nothing to escape *)
+    ; "mappings", mappings
     ]
   in
   match t.sources_contents with
   | None -> `Assoc fields
-  | Some (Source_map.Sources_contents.Uninterpreted cs) ->
+  | Some cs ->
       `Assoc
         (fields
         @ [ ( "sourcesContent"
-              (* It is the job of {!mod:Sources_contents} to enforce that [cs] is
-                 already a valid JSON string literal *)
-            , `Stringlit cs )
+            , `List (List.map (fun t -> `Stringlit (Source_text.to_json_string t))
+            cs) )
           ])
 
 let invalid () = invalid_arg "Source_map.of_json"
@@ -89,6 +90,17 @@ let stringlit_opt name assoc =
   | `Stringlit s -> Some s
   | _ | (exception Not_found) -> None
 
+let stringlit_list_opt name assoc =
+  match List.assoc name assoc with
+  | `List l ->
+      Some (List.map
+              (function
+                | `Stringlit lit -> lit
+                | _ -> invalid ())
+              l)
+  | _ -> invalid ()
+  | exception Not_found -> None
+
 let of_json json =
   match json with
   | `Assoc (("version", version) :: rest) ->
@@ -105,7 +117,7 @@ let of_json json =
       let sourceroot = string "sourceRoot" rest in
       let names = list_string "names" rest in
       let sources = list_string "sources" rest in
-      let sources_contents = stringlit_opt "sourcesContent" rest in
+      let sources_contents = stringlit_list_opt "sourcesContent" rest in
       let mappings = stringlit_opt "mappings" rest in
       let mappings =
         Option.map
@@ -114,15 +126,14 @@ let of_json json =
               String.length mappings >= 2
               && Char.equal mappings.[0] '"'
               && Char.equal mappings.[String.length mappings - 1] '"');
-            let mappings = String.sub mappings 1 (String.length mappings - 2) in
-            Mappings.uninterpreted mappings)
+            Mappings.of_string (String.sub mappings 1 (String.length mappings - 2)))
           mappings
       in
       { version = 3
       ; file = Option.value file ~default:""
       ; sourceroot
       ; names = Option.value names ~default:[]
-      ; sources_contents = Option.map Sources_contents.uninterpreted sources_contents
+      ; sources_contents = Option.map (List.map Source_text.of_json_string) sources_contents
       ; sources = Option.value sources ~default:[]
       ; mappings = Option.value mappings ~default:Mappings.empty
       }