Support the parsing of composite sourcemaps

compiler/lib/link_js.ml

@@ -170,14 +170,19 @@ let prefix_kind line =
       | true -> `Json_base64 (String.length sourceMappingURL_base64)
       | false -> `Url (String.length sourceMappingURL))
 
+let rule_out_index_map = function
+  | `Standard sm -> sm
+  | `Index _ -> failwith "unexpected index map at this stage"
+
 let action ~resolve_sourcemap_url ~drop_source_map file line =
   match prefix_kind line, drop_source_map with
   | `Other, (true | false) -> Keep
   | `Unit, (true | false) -> Unit
   | `Build_info bi, _ -> Build_info bi
   | (`Json_base64 _ | `Url _), true -> Drop
   | `Json_base64 offset, false ->
-      Source_map (Source_map.of_string (Base64.decode_exn ~off:offset line))
+      Source_map
+        (rule_out_index_map (Source_map.of_string (Base64.decode_exn ~off:offset line)))
   | `Url _, false when not resolve_sourcemap_url -> Drop
   | `Url offset, false ->
       let url = String.sub line ~pos:offset ~len:(String.length line - offset) in
@@ -186,7 +191,7 @@ let action ~resolve_sourcemap_url ~drop_source_map file line =
       let l = in_channel_length ic in
       let content = really_input_string ic l in
       close_in ic;
-      Source_map (Source_map.of_string content)
+      Source_map (rule_out_index_map (Source_map.of_string content))
 
 module Units : sig
   val read : Line_reader.t -> Unit_info.t -> Unit_info.t

compiler/lib/source_map.ml

@@ -57,7 +57,6 @@ let gen_line = function
 let gen_col = function
   | Gen { gen_col; _ } | Gen_Ori { gen_col; _ } | Gen_Ori_Name { gen_col; _ } -> gen_col
 
-
 module Line_edits = struct
   type action =
     | Keep
@@ -76,7 +75,6 @@ module Line_edits = struct
   let pp fmt = Format.(pp_print_list pp_action fmt)
 end
 
-
 module Mappings = struct
   type t = Uninterpreted of string [@@unboxed]
 
@@ -579,7 +577,6 @@ let empty ~filename =
   ; mappings = Mappings.empty
   }
 
-
 let concat ~file ~sourceroot s1 s2 =
   if not (Int.equal s1.version s2.version)
   then invalid_arg "Source_map.concat: different versions";
@@ -695,15 +692,15 @@ let merge = function
 
 (* IO *)
 
+let rewrite_path path =
+  if Filename.is_relative path
+  then path
+  else
+    match Build_path_prefix_map.get_build_path_prefix_map () with
+    | Some map -> Build_path_prefix_map.rewrite map path
+    | None -> path
+
 let json t =
-  let rewrite_path path =
-    if Filename.is_relative path
-    then path
-    else
-      match Build_path_prefix_map.get_build_path_prefix_map () with
-      | Some map -> Build_path_prefix_map.rewrite map path
-      | None -> path
-  in
   let stringlit s = `Stringlit (Yojson.Safe.to_string (`String s)) in
   `Assoc
     [ "version", `Intlit (string_of_int t.version)
@@ -764,7 +761,7 @@ let list_stringlit_opt name rest =
     | _ -> invalid ()
   with Not_found -> None
 
-let of_json (json : Yojson.Raw.t) =
+let standard_map_of_json (json : Yojson.Raw.t) =
   match json with
   | `Assoc (("version", `Intlit version) :: rest) when int_of_string version = 3 ->
       let string name json = Option.map ~f:string_of_stringlit (stringlit name json) in
@@ -808,8 +805,116 @@ let of_json (json : Yojson.Raw.t) =
       }
   | _ -> invalid ()
 
-let of_string s = of_json (Yojson.Raw.from_string s)
-
 let to_string m = Yojson.Raw.to_string (json m)
 
 let to_file m file = Yojson.Raw.to_file file (json m)
+
+module Index = struct
+  type offset =
+    { gen_line : int
+    ; gen_column : int
+    }
+
+  (* Type synonym to avoid confusion between toplevel [t] and this submodule's [t]. *)
+  type map = t
+
+  type t =
+    { version : int
+    ; file : string
+    ; sections : (offset * [ `Map of map ]) list
+    }
+
+  let json t =
+    let stringlit s = `Stringlit (Yojson.Safe.to_string (`String s)) in
+    `Assoc
+      [ "version", `Intlit (string_of_int t.version)
+      ; "file", stringlit (rewrite_path t.file)
+      ; ( "sections"
+        , `List
+            (List.map
+               ~f:(fun ({ gen_line; gen_column }, `Map sm) ->
+                 `Assoc
+                   [ ( "offset"
+                     , `Assoc
+                         [ "line", `Intlit (string_of_int gen_line)
+                         ; "column", `Intlit (string_of_int gen_column)
+                         ] )
+                   ; "map", json sm
+                   ])
+               t.sections) )
+      ]
+
+  let intlit ~errmsg name json =
+    match List.assoc name json with
+    | `Intlit i -> int_of_string i
+    | _ -> invalid_arg errmsg
+    | exception Not_found -> invalid_arg errmsg
+
+  let section_of_json : Yojson.Raw.t -> offset * [ `Map of map ] = function
+    | `Assoc json ->
+        let offset =
+          match List.assoc "offset" json with
+          | `Assoc fields ->
+              let gen_line =
+                intlit
+                  "line"
+                  fields
+                  ~errmsg:
+                    "Source_map_io.Index.of_json: field 'line' absent or invalid from \
+                     section"
+              in
+              let gen_column =
+                intlit
+                  "column"
+                  fields
+                  ~errmsg:
+                    "Source_map_io.Index.of_json: field 'column' absent or invalid from \
+                     section"
+              in
+              { gen_line; gen_column }
+          | _ ->
+              invalid_arg "Source_map_io.Index.of_json: 'offset' field of unexpected type"
+        in
+        (match List.assoc "url" json with
+        | _ ->
+            invalid_arg
+              "Source_map_io.Index.of_json: URLs in index maps are not currently \
+               supported"
+        | exception Not_found -> ());
+        let map =
+          try standard_map_of_json (List.assoc "map" json) with
+          | Not_found -> invalid_arg "Source_map_io.Index.of_json: field 'map' absent"
+          | Invalid_argument _ ->
+              invalid_arg "Source_map_io.Index.of_json: invalid sub-map object"
+        in
+        offset, `Map map
+    | _ -> invalid_arg "Source_map_io.Index.of_json: section of unexpected type"
+
+  let of_json = function
+    | `Assoc fields -> (
+        let string name json = Option.map ~f:string_of_stringlit (stringlit name json) in
+        let file = string "file" fields in
+        match List.assoc "sections" fields with
+        | `List sections ->
+            let sections = List.map ~f:section_of_json sections in
+            { version = 3; file = Option.value file ~default:""; sections }
+        | _ -> invalid_arg "Source_map_io.Index.of_json: `sections` is not an array"
+        | exception Not_found ->
+            invalid_arg "Source_map_io.Index.of_json: no `sections` field")
+    | _ -> invalid_arg "Source_map_io.of_json: map is not an object"
+
+  let to_string m = Yojson.Raw.to_string (json m)
+
+  let to_file m file = Yojson.Raw.to_file file (json m)
+end
+
+let of_json = function
+  | `Assoc fields as json -> (
+      match List.assoc "sections" fields with
+      | _ -> `Index (Index.of_json json)
+      | exception Not_found -> `Standard (standard_map_of_json json))
+  | _ -> invalid_arg "Source_map_io.of_json: map is not an object"
+
+let of_string s = of_json (Yojson.Raw.from_string s)
+
+let of_file f = of_json (Yojson.Raw.from_file f)

compiler/lib/source_map.mli

@@ -108,8 +108,16 @@ type t =
   }
 
 val filter_map : t -> f:(int -> int option) -> t
+(** If [f l] returns [Some l'], map line [l] to [l'] (in the generated file) in
+    the returned debug mappings. If [f l] returns [None], remove debug mappings
+    which concern line [l] of the generated file. The time cost of this
+    function is more than linear in the size of the input mappings. When
+    possible, prefer using {!val:Mappings.edit}. *)
 
 val merge : t list -> t option
+(** Merge two lists of debug mappings. The time cost of the merge is more than
+    linear in function of the size of the input mappings. When possible, prefer
+    using {!val:concat}. *)
 
 val empty : filename:string -> t
 
@@ -119,8 +127,31 @@ val concat : file:string -> sourceroot:string option -> t -> t -> t
     union of these mappings for the concatenation of [f1] and [f2], with name
     [file] and source root [sourceroot). *)
 
+module Index : sig
+  type offset =
+    { gen_line : int
+    ; gen_column : int
+    }
+
+  type nonrec t =
+    { version : int
+    ; file : string
+    ; sections : (offset * [ `Map of t ]) list
+          (** List of [(offset, map)] pairs. The sourcemap spec allows for [map] to be
+            either a sourcemap object or a URL, but we don't need to generate
+            composite sourcemaps with URLs for now, and it is therefore not
+            implemented. *)
+    }
+
+  val to_string : t -> string
+
+  val to_file : t -> string -> unit
+end
+
 val to_string : t -> string
 
 val to_file : t -> string -> unit
 
-val of_string : string -> t
+val of_string : string -> [ `Standard of t | `Index of Index.t ]
+
+val of_file : string -> [ `Standard of t | `Index of Index.t ]

compiler/tests-compiler/build_path_prefix_map.ml

@@ -29,12 +29,13 @@ let%expect_test _ =
       |> compile_cmo_to_javascript ~sourcemap:true ~pretty:false
       |> extract_sourcemap
       |> function
-      | Some (sm : Js_of_ocaml_compiler.Source_map.t) ->
+      | Some (`Standard (sm : Js_of_ocaml_compiler.Source_map.t)) ->
           Printf.printf "file: %s\n" sm.file;
           Printf.printf "sourceRoot: %s\n" (Option.value ~default:"<none>" sm.sourceroot);
           Printf.printf "sources:\n";
           List.iter sm.sources ~f:(fun source ->
               Printf.printf "- %s\n" (normalize_path source))
+      | Some (`Index _) -> failwith "unexpected index map"
       | None -> failwith "no sourcemap generated!");
   [%expect
     {|

compiler/tests-compiler/sourcemap.ml

@@ -55,7 +55,8 @@ let%expect_test _ =
       print_file (Filetype.path_of_js_file js_file);
       match extract_sourcemap js_file with
       | None -> Printf.printf "No sourcemap found\n"
-      | Some sm -> print_mapping sm);
+      | Some (`Standard sm) -> print_mapping sm
+      | Some (`Index _) -> failwith "unexpected index map");
   [%expect
     {|
       $ cat "test.ml"
@@ -140,16 +141,19 @@ let%expect_test _ =
     ; mappings = Source_map.Mappings.encode [ gen (3, 3) (5, 5) 0 ]
     }
   in
-  let m = Source_map.merge [ s1; Source_map.filter_map s2 ~f:(fun x -> Some (x + 20)) ] in
-  (match m with
-  | None -> ()
-  | Some sm ->
-      let encoded_mappings = sm.Source_map.mappings in
-      print_endline (Source_map.Mappings.to_string encoded_mappings);
-      print_mapping sm);
+  let edits =
+    Source_map.Line_edits.([ Add { count = 17 } ] @ List.init ~len:3 ~f:(Fun.const Keep))
+  in
+  let s2 =
+    { s2 with mappings = Source_map.Mappings.edit ~strict:true s2.mappings edits }
+  in
+  let m = Source_map.concat ~file:"" ~sourceroot:None s1 s2 in
+  let encoded_mappings = m.Source_map.mappings in
+  print_endline (Source_map.Mappings.to_string encoded_mappings);
+  print_mapping m;
   [%expect
     {|
-    CASU;;GCUU;;;;;;;;;;;;;;;;;;;;GCff
+    CASU;;GCUU;;;;;;;;;;;;;;;;;;;;GCff;
     sa:10:10 -> 1:1
     sb:20:20 -> 3:3
     sa2:5:5 -> 23:3 |}]

compiler/tests-compiler/util/util.mli

@@ -53,7 +53,12 @@ val compile_bc_to_javascript :
 val jsoo_minify :
   ?flags:string list -> pretty:bool -> Filetype.js_file -> Filetype.js_file
 
-val extract_sourcemap : Filetype.js_file -> Js_of_ocaml_compiler.Source_map.t option
+val extract_sourcemap :
+     Filetype.js_file
+  -> [ `Standard of Js_of_ocaml_compiler.Source_map.t
+     | `Index of Js_of_ocaml_compiler.Source_map.Index.t
+     ]
+     option
 
 val run_javascript : Filetype.js_file -> string
 

compiler/tests-sourcemap/dump_sourcemap.ml

@@ -36,7 +36,7 @@ let extract_sourcemap lines =
       Some (Source_map.of_string content)
   | _ -> None
 
-let print_mapping lines (sm : Source_map.t) =
+let print_mapping lines ?(line_offset = 0) (sm : Source_map.t) =
   let lines = Array.of_list lines in
   let sources = Array.of_list sm.sources in
   let _names = Array.of_list sm.names in
@@ -68,9 +68,18 @@ let print_mapping lines (sm : Source_map.t) =
                 ori_line
                 ori_col
                 gen_col
-                (mark gen_col lines.(gen_line - 1))
+                (mark gen_col lines.(gen_line - 1 + line_offset))
           | _ -> ()))
 
+let print_sourcemap lines = function
+  | `Standard sm -> print_mapping lines sm
+  | `Index l ->
+      List.iter
+        l.Source_map.Index.sections
+        ~f:(fun (Source_map.Index.{ gen_line; gen_column }, `Map sm) ->
+          assert (gen_column = 0);
+          print_mapping lines ~line_offset:gen_line sm)
+
 let files = Sys.argv |> Array.to_list |> List.tl
 
 let () =
@@ -80,4 +89,4 @@ let () =
       | None -> Printf.printf "not sourcemap for %s\n" f
       | Some sm ->
           Printf.printf "sourcemap for %s\n" f;
-          print_mapping lines sm)
+          print_sourcemap lines sm)