Integrate embed lang

jscomp/bsc/rescript_compiler_main.ml

@@ -223,6 +223,9 @@ let buckle_script_flags : (string * Bsc_args.spec * string) array =
     "-I", string_list_add  Clflags.include_dirs ,
     "*internal* <dir>  Add <dir> to the list of include directories" ;
 
+    "-embed", string_list_add  Js_config.embeds ,
+    "TODO: Explain." ;
+
     "-w", string_call (Warnings.parse_options false),
     "<list>  Enable or disable warnings according to <list>:\n\
      +<spec>   enable warnings in <spec>\n\

jscomp/common/js_config.ml

@@ -31,6 +31,8 @@ type jsx_mode = Classic | Automatic
 let no_version_header = ref false
 
 let directives = ref []
+
+let embeds = ref []
 let cross_module_inline = ref false
 let diagnose = ref false
 

jscomp/common/js_config.mli

@@ -32,6 +32,9 @@ type jsx_mode = Classic | Automatic
 val no_version_header : bool ref
 (** set/get header *)
 
+val embeds : string list ref
+(** embeds *)
+
 val directives : string list ref
 (** directives printed verbatims just after the version header *)
 

jscomp/core/js_embeds.ml

@@ -0,0 +1,91 @@
+let escape text =
+  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 -> Buffer.add_char buf c);
+      loop (i + 1))
+  in
+  loop 0;
+  Buffer.contents buf
+
+let write_text output text =
+  let oc = open_out_bin output in
+  output_string oc text;
+  close_out oc
+
+let write_embeds ~extension_points ~module_filename ~output ast =
+  match extension_points with
+  | [] -> write_text output "[]"
+  | extension_points -> (
+    let content = ref [] in
+    let append item = content := item :: !content in
+    let extension (iterator : Ast_iterator.iterator) (ext : Parsetree.extension)
+        =
+      (match ext with
+      | ( {txt},
+          PStr
+            [
+              {
+                pstr_desc =
+                  Pstr_eval
+                    ( {
+                        pexp_loc;
+                        pexp_desc = Pexp_constant (Pconst_string (contents, _));
+                      },
+                      _ );
+              };
+            ] )
+        when extension_points |> List.mem txt ->
+        append (pexp_loc, txt, contents)
+      | _ -> ());
+      Ast_iterator.default_iterator.extension iterator ext
+    in
+    let iterator = {Ast_iterator.default_iterator with extension} in
+    iterator.structure iterator ast;
+    match !content with
+    | [] -> write_text output "[]"
+    | content ->
+      let counts = Hashtbl.create 10 in
+      let text =
+        "[\n"
+        ^ (content |> List.rev
+          |> List.map (fun (loc, extension_name, contents) ->
+                 let current_tag_count =
+                   match Hashtbl.find_opt counts extension_name with
+                   | None -> 0
+                   | Some count -> count
+                 in
+                 let tag_count = current_tag_count + 1 in
+                 Hashtbl.replace counts extension_name tag_count;
+
+                 let target_file_name =
+                   Printf.sprintf "%s.res"
+                     (Bs_embed_lang.make_embed_target_module_name
+                        ~module_filename ~extension_name ~tag_count)
+                 in
+                 Printf.sprintf
+                   "  {\n\
+                   \    \"tag\": \"%s\",\n\
+                   \    \"filename\": \"%s\",\n\
+                   \    \"contents\": \"%s\",\n\
+                   \    \"loc\": {\"start\": {\"line\": %s, \"col\": %s}, \
+                    \"end\": {\"line\": %s, \"col\": %s}}\n\
+                   \  }" (escape extension_name) target_file_name
+                   (escape contents)
+                   (loc.Location.loc_start.pos_lnum |> string_of_int)
+                   ((loc.loc_start.pos_cnum - loc.loc_start.pos_bol) |> string_of_int)
+                   (loc.loc_end.pos_lnum |> string_of_int)
+                   ((loc.loc_end.pos_cnum - loc.loc_end.pos_bol) |> string_of_int))
+          |> String.concat ",\n")
+        ^ "\n]"
+      in
+      write_text output text)

jscomp/core/js_implementation.ml

@@ -127,6 +127,14 @@ let no_export (rest : Parsetree.structure) : Parsetree.structure =
         ]
   | _ -> rest
 
+let write_embeds outputprefix (ast : Parsetree.structure) =
+  if !Clflags.only_parse = false && !Js_config.binary_ast then
+    Js_embeds.write_embeds ~module_filename:outputprefix
+      ~extension_points:!Js_config.embeds
+      ~output:(outputprefix ^ Literals.suffix_embeds)
+      ast;
+  ast
+
 let after_parsing_impl ppf outputprefix (ast : Parsetree.structure) =
   if !Clflags.only_parse = false then (
     Js_config.all_module_aliases :=
@@ -180,6 +188,7 @@ let implementation ~parser ppf ?outputprefix fname =
   in
   Res_compmisc.init_path ();
   parser fname
+  |> write_embeds outputprefix
   |> Cmd_ppx_apply.apply_rewriters ~restore:false ~tool_name:Js_config.tool_name
        Ml
   |> Ppx_entry.rewrite_implementation

jscomp/ext/literals.ml

@@ -111,6 +111,8 @@ let suffix_cmti = ".cmti"
 
 let suffix_ast = ".ast"
 
+let suffix_embeds = ".embeds.json"
+
 let suffix_iast = ".iast"
 
 let suffix_d = ".d"

jscomp/frontend/bs_builtin_ppx.ml

@@ -373,6 +373,11 @@ let signature_item_mapper (self : mapper) (sigi : Parsetree.signature_item) :
 
 let structure_item_mapper (self : mapper) (str : Parsetree.structure_item) :
     Parsetree.structure_item =
+  let str =
+    match !Js_config.embeds with
+    | [] -> str
+    | _ -> Bs_embed_lang.structure_item str
+  in
   match str.pstr_desc with
   | Pstr_type (rf, tdcls) (* [ {ptype_attributes} as tdcl ] *) ->
     Ast_tdcls.handle_tdcls_in_stru self str rf tdcls

jscomp/frontend/bs_embed_lang.ml

@@ -0,0 +1,134 @@
+let should_transform name = !Js_config.embeds |> List.mem name
+
+let make_embed_target_module_name ~module_filename ~extension_name ~tag_count =
+  Printf.sprintf "%s__%s_%i"
+    (String.capitalize_ascii module_filename)
+    (String.map (fun c -> if c = '.' then '_' else c) extension_name)
+    tag_count
+
+let transformed_count = Hashtbl.create 10
+
+let escaped_name_for_ext ?fn_name (ext_name : string) =
+  match fn_name with
+  | Some fn_name -> ext_name ^ "_" ^ fn_name
+  | None -> ext_name
+
+let increment_transformed_count ?fn_name (ext_name : string) =
+  let name = escaped_name_for_ext ?fn_name ext_name in
+  match Hashtbl.find_opt transformed_count name with
+  | None -> Hashtbl.add transformed_count name 1
+  | Some count -> Hashtbl.replace transformed_count name (count + 1)
+
+let get_transformed_count ext_name =
+  match Hashtbl.find_opt transformed_count ext_name with
+  | None -> 0
+  | Some count -> count
+
+type transformMode = LetBinding | ModuleBinding
+
+let make_lident ~extension_name ~transform_mode filename =
+  let module_name =
+    if String.ends_with filename ~suffix:".res" then
+      Filename.(chop_suffix (basename filename) ".res")
+    else Filename.(chop_suffix (basename filename) ".resi")
+  in
+  Longident.parse
+    (Printf.sprintf "%s%s"
+       (make_embed_target_module_name ~module_filename:module_name
+          ~extension_name
+          ~tag_count:(get_transformed_count extension_name))
+       (match transform_mode with
+       | LetBinding -> ".default"
+       | ModuleBinding -> ""))
+
+let transform_expr expr =
+  match expr.Parsetree.pexp_desc with
+  | Pexp_extension
+      ( {txt = extension_name},
+        PStr
+          [
+            {
+              pstr_desc =
+                Pstr_eval ({pexp_desc = Pexp_constant (Pconst_string (_, _))}, _);
+            };
+          ] )
+    when should_transform extension_name ->
+    increment_transformed_count extension_name;
+    let loc = expr.pexp_loc in
+    let filename = loc.loc_start.pos_fname in
+    let lid = make_lident ~extension_name ~transform_mode:LetBinding filename in
+    Ast_helper.Exp.ident ~loc {txt = lid; loc}
+  | _ -> expr
+
+let structure_item structure_item =
+  match structure_item.Parsetree.pstr_desc with
+  | Pstr_value
+      ( recFlag,
+        [
+          ({
+             pvb_expr =
+               {pexp_desc = Pexp_extension ({txt = extension_name}, _)} as expr;
+           } as valueBinding);
+        ] )
+    when should_transform extension_name ->
+    {
+      structure_item with
+      pstr_desc =
+        Pstr_value
+          (recFlag, [{valueBinding with pvb_expr = transform_expr expr}]);
+    }
+  | Pstr_include
+      ({
+         pincl_mod =
+           {pmod_desc = Pmod_extension ({txt = extension_name; loc}, _)} as pmod;
+       } as pincl)
+    when should_transform extension_name ->
+    increment_transformed_count extension_name;
+    {
+      structure_item with
+      pstr_desc =
+        Pstr_include
+          {
+            pincl with
+            pincl_mod =
+              {
+                pmod with
+                pmod_desc =
+                  Pmod_ident
+                    {
+                      txt =
+                        make_lident loc.loc_start.pos_fname ~extension_name
+                          ~transform_mode:ModuleBinding;
+                      loc;
+                    };
+              };
+          };
+    }
+  | Pstr_module
+      ({
+         pmb_expr =
+           {pmod_desc = Pmod_extension ({txt = extension_name; loc}, _)} as pmod;
+       } as pmb)
+    when should_transform extension_name ->
+    increment_transformed_count extension_name;
+    {
+      structure_item with
+      pstr_desc =
+        Pstr_module
+          {
+            pmb with
+            pmb_expr =
+              {
+                pmod with
+                pmod_desc =
+                  Pmod_ident
+                    {
+                      txt =
+                        make_lident loc.loc_start.pos_fname ~extension_name
+                          ~transform_mode:ModuleBinding;
+                      loc;
+                    };
+              };
+          };
+    }
+  | _ -> structure_item