js_implementation.ml

(***********************************************************************)
(*                                                                     *)
(*                                OCaml                                *)
(*                                                                     *)
(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
(*                                                                     *)
(*  Copyright 2002 Institut National de Recherche en Informatique et   *)
(*  en Automatique.  All rights reserved.  This file is distributed    *)
(*  under the terms of the Q Public License version 1.0.               *)
(*                                                                     *)
(***********************************************************************)

(* adapted by rescript from [driver/compile.ml] for convenience    *)

let module_of_filename outputprefix =
  let basename = Filename.basename outputprefix in
  let name =
    try
      let pos = String.index basename '.' in
      String.sub basename 0 pos
    with Not_found -> basename
  in
  String.capitalize_ascii name

let fprintf = Format.fprintf

let print_if_pipe ppf flag printer arg =
  if !flag then fprintf ppf "%a@." printer arg;
  arg

let print_if ppf flag printer arg = if !flag then fprintf ppf "%a@." printer arg

let output_deps_set name set =
  output_string stdout name;
  output_string stdout ": ";
  Depend.StringSet.iter
    (fun s ->
      if s <> "" && s.[0] <> '*' then (
        output_string stdout s;
        output_string stdout " "))
    set;
  output_string stdout "\n"

let process_with_gentype filename =
  match !Clflags.bs_gentype with
  | None -> ()
  | Some cmd ->
      let comm =
        cmd ^ " -bs-version " ^ Bs_version.version ^ " -cmt-add " ^ filename
        ^ ":" ^ !Location.input_name
      in
      if !Clflags.verbose then (
        prerr_string "+ ";
        prerr_endline comm;
        prerr_newline ());
      ignore (Sys.command comm)

let after_parsing_sig ppf outputprefix ast =
  Ast_config.iter_on_bs_config_sigi ast;
  if !Js_config.modules then
    output_deps_set !Location.input_name
      (Ast_extract.read_parse_and_extract Mli ast);
  (if !Js_config.binary_ast then
   let sourcefile = !Location.input_name in
   Binary_ast.write_ast Mli ~sourcefile
     ~output:(outputprefix ^ Literals.suffix_iast)
     (* to support relocate to another directory *)
     ast);
  if !Js_config.as_pp then (
    output_string stdout Config.ast_intf_magic_number;
    output_value stdout (!Location.input_name : string);
    output_value stdout ast);
  if !Js_config.syntax_only then Warnings.check_fatal ()
  else
    let modulename = module_of_filename outputprefix in
    Lam_compile_env.reset ();
    let initial_env = Res_compmisc.initial_env () in
    Env.set_unit_name modulename;
    let tsg = Typemod.transl_signature initial_env ast in
    if !Clflags.dump_typedtree then fprintf ppf "%a@." Printtyped.interface tsg;
    let sg = tsg.sig_type in
    ignore (Includemod.signatures initial_env sg sg);
    Delayed_checks.force_delayed_checks ();
    Warnings.check_fatal ();
    let deprecated = Builtin_attributes.deprecated_of_sig ast in
    let sg =
      Env.save_signature ~deprecated sg modulename (outputprefix ^ ".cmi")
    in
    Typemod.save_signature modulename tsg outputprefix !Location.input_name
      initial_env sg;
    process_with_gentype (outputprefix ^ ".cmti")

let interface ~parser ppf ?outputprefix fname =
  let outputprefix =
    match outputprefix with
    | None -> Config_util.output_prefix fname
    | Some x -> x
  in
  Res_compmisc.init_path ();
  parser fname
  |> Cmd_ppx_apply.apply_rewriters ~restore:false ~tool_name:Js_config.tool_name
       Mli
  |> Ppx_entry.rewrite_signature
  |> print_if_pipe ppf Clflags.dump_parsetree Printast.interface
  |> print_if_pipe ppf Clflags.dump_source Pprintast.signature
  |> after_parsing_sig ppf outputprefix

let interface_mliast ppf fname setup =
  Res_compmisc.init_path ();
  Binary_ast.read_ast_exn ~fname Mli setup
  |> print_if_pipe ppf Clflags.dump_parsetree Printast.interface
  |> print_if_pipe ppf Clflags.dump_source Pprintast.signature
  |> after_parsing_sig ppf (Config_util.output_prefix fname)

let all_module_alias (ast : Parsetree.structure) =
  Ext_list.for_all ast (fun { pstr_desc } ->
      match pstr_desc with
      | Pstr_module { pmb_expr = { pmod_desc = Pmod_ident _ } } -> true
      | Pstr_attribute _ -> true
      | Pstr_eval _ | Pstr_value _ | Pstr_primitive _ | Pstr_type _
      | Pstr_typext _ | Pstr_exception _ | Pstr_module _ | Pstr_recmodule _
      | Pstr_modtype _ | Pstr_open _ | Pstr_class _ | Pstr_class_type _
      | Pstr_include _ | Pstr_extension _ ->
          false)

let no_export (rest : Parsetree.structure) : Parsetree.structure =
  match rest with
  | head :: _ ->
      let loc = head.pstr_loc in
      Ast_helper.
        [
          Str.include_ ~loc
            (Incl.mk ~loc
               (Mod.constraint_ ~loc (Mod.structure ~loc rest)
                  (Mty.signature ~loc [])));
        ]
  | _ -> rest

let after_parsing_impl ppf outputprefix (ast : Parsetree.structure) =
  Js_config.all_module_aliases :=
    !Clflags.assume_no_mli = Mli_non_exists && all_module_alias ast;
  Ast_config.iter_on_bs_config_stru ast;
  let ast = if !Js_config.no_export then no_export ast else ast in
  if !Js_config.modules then
    output_deps_set !Location.input_name
      (Ast_extract.read_parse_and_extract Ml ast);
  (if !Js_config.binary_ast then
   let sourcefile = !Location.input_name in
   Binary_ast.write_ast ~sourcefile Ml
     ~output:(outputprefix ^ Literals.suffix_ast)
     ast);
  if !Js_config.as_pp then (
    output_string stdout Config.ast_impl_magic_number;
    output_value stdout (!Location.input_name : string);
    output_value stdout ast);
  if !Js_config.syntax_only then Warnings.check_fatal ()
  else
    let modulename = Ext_filename.module_name outputprefix in
    Lam_compile_env.reset ();
    let env = Res_compmisc.initial_env () in
    Env.set_unit_name modulename;
    let typedtree, coercion, _, _ =
      Typemod.type_implementation_more
        ?check_exists:(if !Js_config.force_cmi then None else Some ())
        !Location.input_name outputprefix modulename env ast
    in
    let typedtree_coercion = (typedtree, coercion) in
    print_if ppf Clflags.dump_typedtree Printtyped.implementation_with_coercion
      typedtree_coercion;
    (if !Js_config.cmi_only then Warnings.check_fatal ()
    else
      let lambda, exports =
        Translmod.transl_implementation modulename typedtree_coercion
      in
      let js_program =
        print_if_pipe ppf Clflags.dump_rawlambda Printlambda.lambda lambda
        |> Lam_compile_main.compile outputprefix exports
      in
      if not !Js_config.cmj_only then
        Lam_compile_main.lambda_as_module js_program outputprefix);
    process_with_gentype (outputprefix ^ ".cmt")

let implementation ~parser ppf ?outputprefix fname =
  let outputprefix =
    match outputprefix with
    | None -> Config_util.output_prefix fname
    | Some x -> x
  in
  Res_compmisc.init_path ();
  parser fname
  |> Cmd_ppx_apply.apply_rewriters ~restore:false ~tool_name:Js_config.tool_name
       Ml
  |> Ppx_entry.rewrite_implementation
  |> print_if_pipe ppf Clflags.dump_parsetree Printast.implementation
  |> print_if_pipe ppf Clflags.dump_source Pprintast.structure
  |> after_parsing_impl ppf outputprefix

let implementation_mlast ppf fname setup =
  Res_compmisc.init_path ();
  Binary_ast.read_ast_exn ~fname Ml setup
  |> print_if_pipe ppf Clflags.dump_parsetree Printast.implementation
  |> print_if_pipe ppf Clflags.dump_source Pprintast.structure
  |> after_parsing_impl ppf (Config_util.output_prefix fname)

let make_structure_item ~ns cunit : Parsetree.structure_item =
  let open Ast_helper in
  let loc = Location.none in
  Str.module_
    (Mb.mk { txt = cunit; loc }
       (Mod.ident { txt = Lident (Ext_namespace_encode.make ~ns cunit); loc }))

(** decoding [.mlmap]
    keep in sync {!Bsb_namespace_map_gen.output}
*)
let implementation_map ppf sourcefile =
  let () = Js_config.cmj_only := true in
  let ichan = open_in_bin sourcefile in
  seek_in ichan (Ext_digest.length + 1);
  let list_of_modules = Ext_io.rev_lines_of_chann ichan in
  close_in ichan;
  let ns = Ext_filename.module_name sourcefile in
  let ml_ast =
    Ext_list.fold_left list_of_modules [] (fun acc line ->
        if Ext_string.is_empty line then acc
        else make_structure_item ~ns line :: acc)
  in
  Res_compmisc.init_path ();
  ml_ast
  |> print_if_pipe ppf Clflags.dump_parsetree Printast.implementation
  |> print_if_pipe ppf Clflags.dump_source Pprintast.structure
  |> after_parsing_impl ppf (Config_util.output_prefix sourcefile)