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 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 process_with_gentype cmt_file =
  if !((Clflags.current ()).bs_gentype) then
    Gentype_main.process_cmt_file cmt_file

let after_parsing_sig ppf outputprefix ast =
  if !((Clflags.current ()).only_parse) = false then (
    Ast_config.process_sig ast;
    (if !((Js_config.current ()).binary_ast) then
       let sourcefile = Location.get_input_name () in
       Binary_ast.write_ast Mli ~sourcefile
         ~output:(outputprefix ^ Literals.suffix_iast)
         (* to support relocate to another directory *)
         ast);
    if !((Js_config.current ()).as_pp) then (
      let output = Compiler_request_output.stdout_channel () in
      output_string output Config.ast_intf_magic_number;
      output_value output (Location.get_input_name () : string);
      output_value output ast);
    if !((Js_config.current ()).syntax_only) then Warnings.check_fatal ()
    else
      let modulename = Ext_filename.module_name outputprefix in
      Lam_compile_env.reset ();
      let initial_env = Res_compmisc.initial_env ~modulename () in
      Env.set_unit_name modulename;
      let tsg = Typemod.transl_signature initial_env ast in
      if !((Clflags.current ()).dump_typedtree) then
        fprintf ppf "%a@." Printtyped.interface tsg;
      let sg = tsg.sig_type in
      Typemod.check_js_names ~toplevel:true sg;
      ignore (Includemod.signatures initial_env sg sg);
      Delayed_checks.force_delayed_checks ();
      Warnings.check_fatal ();
      let deprecated = Builtin_attributes.deprecated_of_sig ast in
      ignore
        (Env.save_signature ~deprecated sg modulename (outputprefix ^ ".cmi"));
      Typemod.save_signature modulename tsg outputprefix
        (Location.get_input_name ());
      process_with_gentype (outputprefix ^ ".cmti"))

let interface ~parser ppf fname =
  let outputprefix = Config_util.output_prefix fname in
  Res_compmisc.init_path ();
  parser fname
  |> Cmd_ppx_apply.apply_rewriters ~tool_name:Js_config.tool_name Mli
  |> Ppx_entry.rewrite_signature
  |> print_if_pipe ppf (Clflags.current ()).dump_parsetree Printast.interface
  |> print_if_pipe ppf (Clflags.current ()).dump_source Pprintast.signature
  |> after_parsing_sig ppf outputprefix

let interface_mliast ppf fname =
  Res_compmisc.init_path ();
  Binary_ast.read_ast_exn ~fname Mli
  |> print_if_pipe ppf (Clflags.current ()).dump_parsetree Printast.interface
  |> print_if_pipe ppf (Clflags.current ()).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_include _ | Pstr_extension _
      | Pstr_raw _ ->
        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) =
  if !((Clflags.current ()).only_parse) = false then (
    (Js_config.current ()).all_module_aliases :=
      !((Clflags.current ()).assume_no_mli) = Mli_non_exists
      && all_module_alias ast;
    Ast_config.process_str ast;
    let ast =
      if !((Js_config.current ()).no_export) then no_export ast else ast
    in
    (if !((Js_config.current ()).binary_ast) then
       let sourcefile = Location.get_input_name () in
       Binary_ast.write_ast ~sourcefile Ml
         ~output:(outputprefix ^ Literals.suffix_ast)
         ast);
    if !((Js_config.current ()).as_pp) then (
      let output = Compiler_request_output.stdout_channel () in
      output_string output Config.ast_impl_magic_number;
      output_value output (Location.get_input_name () : string);
      output_value output ast);
    if !((Js_config.current ()).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 ~modulename () in
      Env.set_unit_name modulename;
      let typedtree, coercion, finalenv, signature =
        Typemod.type_implementation_more
          ?check_exists:
            (if !((Js_config.current ()).force_cmi) then None else Some ())
          (Location.get_input_name ())
          outputprefix modulename env ast
      in
      let typedtree_coercion = (typedtree, coercion) in
      print_if ppf (Clflags.current ()).dump_typedtree
        Printtyped.implementation_with_coercion typedtree_coercion;
      (if !((Js_config.current ()).cmi_only) then Warnings.check_fatal ()
       else
         let implementation =
           Translmod.transl_implementation modulename finalenv signature
             typedtree_coercion
         in
         print_if ppf (Clflags.current ()).dump_rawlambda Printlambda.lambda
           implementation.lambda;
         let js_program =
           Lam_compile_main.compile outputprefix implementation
         in
         if not !((Js_config.current ()).cmj_only) then
           Lam_compile_main.lambda_as_module js_program outputprefix);
      process_with_gentype (outputprefix ^ ".cmt"))

let implementation ~parser ppf fname =
  let outputprefix = Config_util.output_prefix fname in
  Res_compmisc.init_path ();
  parser fname
  |> Cmd_ppx_apply.apply_rewriters ~tool_name:Js_config.tool_name Ml
  |> Ppx_entry.rewrite_implementation
  |> print_if_pipe ppf (Clflags.current ()).dump_parsetree
       Printast.implementation
  |> print_if_pipe ppf (Clflags.current ()).dump_source Pprintast.structure
  |> after_parsing_impl ppf outputprefix

let implementation_mlast ppf fname =
  Res_compmisc.init_path ();
  Binary_ast.read_ast_exn ~fname Ml
  |> print_if_pipe ppf (Clflags.current ()).dump_parsetree
       Printast.implementation
  |> print_if_pipe ppf (Clflags.current ()).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 with [namespace_task] in rewatch-ocaml/compiler_process.ml
*)
let implementation_map ppf sourcefile =
  let () = (Js_config.current ()).cmj_only := true in
  let ichan = open_in_bin (Compiler_request_state.resolve_path 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 (Filename.remove_extension sourcefile) in
  let ml_ast =
    Ext_list.fold_left list_of_modules [] (fun acc line ->
        if line = "" then acc else make_structure_item ~ns line :: acc)
  in
  Res_compmisc.init_path ();
  ml_ast
  |> print_if_pipe ppf (Clflags.current ()).dump_parsetree
       Printast.implementation
  |> print_if_pipe ppf (Clflags.current ()).dump_source Pprintast.structure
  |> after_parsing_impl ppf (Config_util.output_prefix sourcefile)