diff --git a/jscomp/bsc/rescript_compiler_main.ml b/jscomp/bsc/rescript_compiler_main.ml index 16e927f42b..a7515d6e06 100644 --- a/jscomp/bsc/rescript_compiler_main.ml +++ b/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* Add to the list of include directories" ; + "-embed", string_list_add Js_config.embeds , + "TODO: Explain." ; + "-w", string_call (Warnings.parse_options false), " Enable or disable warnings according to :\n\ + enable warnings in \n\ diff --git a/jscomp/common/js_config.ml b/jscomp/common/js_config.ml index 84f4e22f68..45f572e443 100644 --- a/jscomp/common/js_config.ml +++ b/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 diff --git a/jscomp/common/js_config.mli b/jscomp/common/js_config.mli index 31855eaca7..bb4d75fc77 100644 --- a/jscomp/common/js_config.mli +++ b/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 *) diff --git a/jscomp/core/js_embeds.ml b/jscomp/core/js_embeds.ml new file mode 100644 index 0000000000..4ba895dca4 --- /dev/null +++ b/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) diff --git a/jscomp/core/js_implementation.ml b/jscomp/core/js_implementation.ml index 9bf84c8264..d36be0e42b 100644 --- a/jscomp/core/js_implementation.ml +++ b/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 diff --git a/jscomp/ext/literals.ml b/jscomp/ext/literals.ml index 34163c0c6d..24e3c53a59 100644 --- a/jscomp/ext/literals.ml +++ b/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" diff --git a/jscomp/frontend/bs_builtin_ppx.ml b/jscomp/frontend/bs_builtin_ppx.ml index bf9bdb53ad..b27f52ea32 100644 --- a/jscomp/frontend/bs_builtin_ppx.ml +++ b/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 diff --git a/jscomp/frontend/bs_embed_lang.ml b/jscomp/frontend/bs_embed_lang.ml new file mode 100644 index 0000000000..4e0bab4337 --- /dev/null +++ b/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