28906

Committed 03 Nov 2024 03:55PM UTC coverage: 6.917% (+0.005%) from 6.912%

Build # 28906

Build Type

push

github

Committed by

web-flow

Commit Message

refactor: remove a bunch of useless "let open Memo.O in" (#11086)

Signed-off-by: Rudi Grinberg <me@rgrinberg.com>

Run Details

0 of 6 new or added lines in 3 files covered. (0.0%)

66 existing lines in 40 files now uncovered.

2933 of 42401 relevant lines covered (6.92%)

26866.68 hits per line

Source File
Press 'n' to go to next uncovered line, 'b' for previous

0.0

/src/dune_rules/module_compilation.ml

open Import
open Memo.O

(* Arguments for the compiler to prevent it from being too clever.

   The compiler creates the cmi when it thinks a .ml file has no corresponding
   .mli. However this behavior is a bit racy and doesn't work well when the
   extension is not .ml or when the .ml and .mli are in different directories.
   This flags makes the compiler think there is a .mli file and will the read
   the cmi file rather than create it. *)
let force_read_cmi source_file = [ "-intf-suffix"; Path.extension source_file ]

(* Build the cm* if the corresponding source is present, in the case of cmi if
   the mli is not present it is added as additional target to the .cmo
   generation *)

let opens modules m =
  Command.Args.As (Modules.With_vlib.local_open modules m |> Ocaml_flags.open_flags)
;;

let other_cm_files ~opaque ~cm_kind ~obj_dir =
  List.concat_map ~f:(fun m ->
    let cmi_kind = Lib_mode.Cm_kind.cmi cm_kind in
    let deps = [ Path.build (Obj_dir.Module.cm_file_exn obj_dir m ~kind:cmi_kind) ] in
    if Module.has m ~ml_kind:Impl && cm_kind = Ocaml Cmx && not opaque
    then (
      let cmx = Obj_dir.Module.cm_file_exn obj_dir m ~kind:(Ocaml Cmx) in
      Path.build cmx :: deps)
    else if Module.has m ~ml_kind:Impl && cm_kind = Melange Cmj
    then (
      let cmj = Obj_dir.Module.cm_file_exn obj_dir m ~kind:(Melange Cmj) in
      Path.build cmj :: deps)
    else deps)
;;

let copy_interface ~sctx ~dir ~obj_dir ~cm_kind m =
  (* symlink the .cmi into the public interface directory *)
  Memo.when_
    (Module.visibility m <> Visibility.Private
     && Obj_dir.need_dedicated_public_dir obj_dir)
    (fun () ->
      let cmi_kind = Lib_mode.Cm_kind.cmi cm_kind in
      Super_context.add_rule
        sctx
        ~dir
        (Action_builder.symlink
           ~src:(Path.build (Obj_dir.Module.cm_file_exn obj_dir m ~kind:cmi_kind))
           ~dst:(Obj_dir.Module.cm_public_file_exn obj_dir m ~kind:cmi_kind)))
;;

let melange_args (cctx : Compilation_context.t) (cm_kind : Lib_mode.Cm_kind.t) module_ =
  match cm_kind with
  | Ocaml (Cmi | Cmo | Cmx) | Melange Cmi -> []
  | Melange Cmj ->
    let bs_package_name, bs_package_output =
      let package_output =
        Module.file ~ml_kind:Impl module_ |> Option.value_exn |> Path.parent_exn
      in
      match Compilation_context.melange_package_name cctx with
      | None -> [], package_output
      | Some lib_name ->
        let dir =
          let package_output = Path.as_in_build_dir_exn package_output in
          let lib_root_dir = Path.build (Compilation_context.dir cctx) in
          let src_dir = Path.build package_output in
          let build_dir =
            Compilation_context.super_context cctx
            |> Super_context.context
            |> Context.build_dir
          in
          Path.drop_prefix_exn src_dir ~prefix:lib_root_dir
          |> Path.Local.to_string
          |> Path.Build.relative build_dir
        in
        ( [ Command.Args.A "--bs-package-name"; A (Lib_name.to_string lib_name) ]
        , Path.build dir )
    in
    Command.Args.A "--bs-stop-after-cmj"
    :: A "--bs-package-output"
    :: Command.Args.Path bs_package_output
    :: A "--bs-module-name"
    :: A (Melange.js_basename module_)
    :: bs_package_name
;;

let build_cm
  cctx
  ~force_write_cmi
  ~precompiled_cmi
  ~cm_kind
  (m : Module.t)
  ~(phase : Fdo.phase option)
  =
  if force_write_cmi && precompiled_cmi
  then Code_error.raise "force_read_cmi and precompiled_cmi are mutually exclusive" [];
  let sctx = Compilation_context.super_context cctx in
  let dir = Compilation_context.dir cctx in
  let obj_dir = Compilation_context.obj_dir cctx in
  let ctx = Super_context.context sctx in
  let mode = Lib_mode.of_cm_kind cm_kind in
  let sandbox =
    let default = Compilation_context.sandbox cctx in
    match Module.kind m with
    | Root ->
      (* This is need to guarantee that no local modules shadow the modules
         referenced by the root module *)
      Sandbox_config.needs_sandboxing
    | _ -> default
  in
  let ocaml = Compilation_context.ocaml cctx in
  let* compiler =
    match mode with
    | Melange ->
      let loc = Compilation_context.loc cctx in
      let+ melc = Melange_binary.melc sctx ~loc ~dir in
      Some melc
    | Ocaml mode ->
      Memo.return
        (let compiler = Ocaml_toolchain.compiler ocaml mode in
         (* TODO one day remove this silly optimization *)
         match compiler with
         | Ok _ as s -> Some s
         | Error _ -> None)
  in
  (let open Option.O in
   let* compiler = compiler in
   let ml_kind = Lib_mode.Cm_kind.source cm_kind in
   let+ src = Module.file m ~ml_kind in
   let dst = Obj_dir.Module.cm_file_exn obj_dir m ~kind:cm_kind in
   let obj =
     Obj_dir.Module.obj_file obj_dir m ~kind:(Ocaml Cmx) ~ext:ocaml.lib_config.ext_obj
   in
   let open Memo.O in
   let* extra_args, extra_deps, other_targets =
     if precompiled_cmi
     then Memo.return (force_read_cmi src, [], [])
     else (
       (* If we're compiling an implementation, then the cmi is present *)
       let public_vlib_module = Module.kind m = Impl_vmodule in
       match phase with
       | Some Emit -> Memo.return ([], [], [])
       | Some Compile | Some All | None ->
         (match cm_kind, Module.file m ~ml_kind:Intf, public_vlib_module with
          (* If there is no mli, [ocamlY -c file.ml] produces both the .cmY and
             .cmi. We choose to use ocamlc to produce the cmi and to produce the
             cmx we have to wait to avoid race conditions. *)
          | (Ocaml Cmo | Melange Cmj), None, false ->
            if force_write_cmi
            then Memo.return ([ "-intf-suffix"; ".dummy-ignore-mli" ], [], [])
            else
              let+ () = copy_interface ~dir ~obj_dir ~sctx ~cm_kind m in
              let cmi_kind = Lib_mode.Cm_kind.cmi cm_kind in
              [], [], [ Obj_dir.Module.cm_file_exn obj_dir m ~kind:cmi_kind ]
          | (Ocaml Cmo | Melange Cmj), None, true
          | (Ocaml (Cmo | Cmx) | Melange Cmj), _, _ ->
            let cmi_kind = Lib_mode.Cm_kind.cmi cm_kind in
            Memo.return
              ( force_read_cmi src
              , [ Path.build (Obj_dir.Module.cm_file_exn obj_dir m ~kind:cmi_kind) ]
              , [] )
          | (Ocaml Cmi | Melange Cmi), _, _ ->
            let+ () = copy_interface ~dir ~obj_dir ~sctx ~cm_kind m in
            [], [], []))
   in
   let other_targets =
     match cm_kind with
     | Ocaml (Cmi | Cmo) | Melange (Cmi | Cmj) -> other_targets
     | Ocaml Cmx ->
       (match phase with
        | Some Compile ->
          let linear =
            Obj_dir.Module.obj_file obj_dir m ~kind:(Ocaml Cmx) ~ext:Fdo.linear_ext
          in
          linear :: other_targets
        | Some Emit -> other_targets
        | Some All | None -> obj :: other_targets)
   in
   let opaque = Compilation_context.opaque cctx in
   let other_cm_files =
     let dep_graph = Ml_kind.Dict.get (Compilation_context.dep_graphs cctx) ml_kind in
     let module_deps = Dep_graph.deps_of dep_graph m in
     Action_builder.dyn_paths_unit
       (Action_builder.map module_deps ~f:(other_cm_files ~opaque ~cm_kind ~obj_dir))
   in
   let other_targets, cmt_args =
     match cm_kind with
     | Ocaml Cmx -> other_targets, Command.Args.empty
     | Ocaml (Cmi | Cmo) | Melange (Cmi | Cmj) ->
       if Compilation_context.bin_annot cctx
       then (
         let fn =
           Option.value_exn (Obj_dir.Module.cmt_file obj_dir m ~cm_kind ~ml_kind)
         in
         let annots =
           [ "-bin-annot" ]
           @
           if Version.supports_bin_annot_occurrences ocaml.version
           then [ "-bin-annot-occurrences" ]
           else []
         in
         fn :: other_targets, As annots)
       else other_targets, Command.Args.empty
   in
   let opaque_arg : _ Command.Args.t =
     let intf_only = cm_kind = Ocaml Cmi && not (Module.has m ~ml_kind:Impl) in
     if opaque || (intf_only && Ocaml.Version.supports_opaque_for_mli ocaml.version)
     then A "-opaque"
     else Command.Args.empty
   in
   let flags, sandbox =
     let flags =
       Command.Args.dyn (Ocaml_flags.get (Compilation_context.flags cctx) mode)
     in
     match Module.pp_flags m with
     | None -> flags, sandbox
     | Some (pp, sandbox') ->
       S [ flags; Command.Args.dyn pp ], Sandbox_config.inter sandbox sandbox'
   in
   let output =
     match phase with
     | Some Compile -> dst
     | Some Emit -> obj
     | Some All | None -> dst
   in
   let src =
     match phase with
     | Some Emit ->
       let linear_fdo =
         Obj_dir.Module.obj_file obj_dir m ~kind:(Ocaml Cmx) ~ext:Fdo.linear_fdo_ext
       in
       Path.build linear_fdo
     | Some Compile | Some All | None -> src
   in
   let opens =
     let modules = Compilation_context.modules cctx in
     opens modules m
   in
   let obj_dirs =
     Obj_dir.all_obj_dirs obj_dir ~mode
     |> List.concat_map ~f:(fun p -> [ Command.Args.A "-I"; Path (Path.build p) ])
   in
   Super_context.add_rule
     sctx
     ~dir:
       (let dune_version =
          Compilation_context.scope cctx |> Scope.project |> Dune_project.dune_version
        in
        (* TODO DUNE4 get rid of the old behavior *)
        if dune_version >= (3, 7) then dir else Context.build_dir ctx)
     ?loc:(Compilation_context.loc cctx)
     (let open Action_builder.With_targets.O in
      Action_builder.with_no_targets (Action_builder.paths extra_deps)
      >>> Action_builder.with_no_targets other_cm_files
      >>> Command.run
            ~dir:(Path.build (Context.build_dir ctx))
            compiler
            [ flags
            ; cmt_args
            ; Command.Args.S obj_dirs
            ; Command.Args.as_any
                (Lib_mode.Cm_kind.Map.get (Compilation_context.includes cctx) cm_kind)
            ; As extra_args
            ; S (melange_args cctx cm_kind m)
            ; A "-no-alias-deps"
            ; opaque_arg
            ; As (Fdo.phase_flags phase)
            ; opens
            ; As
                (match Compilation_context.stdlib cctx with
                 | None -> []
                 | Some _ ->
                   (* XXX why aren't these just normal library flags? *)
                   [ "-nopervasives"; "-nostdlib" ])
            ; A "-o"
            ; Target output
            ; A "-c"
            ; Command.Ml_kind.flag ml_kind
            ; Dep src
            ; Hidden_targets other_targets
            ]
      >>| Action.Full.add_sandbox sandbox))
  |> Memo.Option.iter ~f:Fun.id
;;

let build_module ?(force_write_cmi = false) ?(precompiled_cmi = false) cctx m =
  let open Memo.O in
  let { Lib_mode.Map.ocaml; melange } = Compilation_context.modes cctx in
  let build_cm = build_cm cctx m ~force_write_cmi ~precompiled_cmi in
  let* () =
    Memo.when_ (ocaml.byte || ocaml.native) (fun () ->
      let* () = build_cm ~cm_kind:(Ocaml Cmo) ~phase:None
      and* () =
        let ctx = Compilation_context.context cctx in
        let ocaml = Compilation_context.ocaml cctx in
        let can_split =
          Ocaml.Version.supports_split_at_emit ocaml.version
          || Ocaml_config.is_dev_version ocaml.ocaml_config
        in
        match Context.fdo_target_exe ctx, can_split with
        | None, _ -> build_cm ~cm_kind:(Ocaml Cmx) ~phase:None
        | Some _, false -> build_cm ~cm_kind:(Ocaml Cmx) ~phase:(Some All)
        | Some _, true ->
          build_cm ~cm_kind:(Ocaml Cmx) ~phase:(Some Compile)
          >>> Fdo.opt_rule cctx m
          >>> build_cm ~cm_kind:(Ocaml Cmx) ~phase:(Some Emit)
      and* () =
        Memo.when_ (not precompiled_cmi) (fun () ->
          build_cm ~cm_kind:(Ocaml Cmi) ~phase:None)
      in
      let obj_dir = Compilation_context.obj_dir cctx in
      match Obj_dir.Module.cm_file obj_dir m ~kind:(Ocaml Cmo) with
      | None -> Memo.return ()
      | Some src ->
        Compilation_context.js_of_ocaml cctx
        |> Memo.Option.iter ~f:(fun in_context ->
          (* Build *.cmo.js *)
          let sctx = Compilation_context.super_context cctx in
          let dir = Compilation_context.dir cctx in
          let action_with_targets =
            Jsoo_rules.build_cm
              sctx
              ~dir
              ~in_context
              ~src:(Path.build src)
              ~obj_dir
              ~config:None
          in
          Super_context.add_rule sctx ~dir action_with_targets))
  in
  Memo.when_ melange (fun () ->
    let* () = build_cm ~cm_kind:(Melange Cmj) ~phase:None in
    Memo.when_ (not precompiled_cmi) (fun () ->
      build_cm ~cm_kind:(Melange Cmi) ~phase:None))
;;

let ocamlc_i ~deps cctx (m : Module.t) ~output =
  let sctx = Compilation_context.super_context cctx in
  let obj_dir = Compilation_context.obj_dir cctx in
  let dir = Compilation_context.dir cctx in
  let ctx = Super_context.context sctx in
  let src = Option.value_exn (Module.file m ~ml_kind:Impl) in
  let sandbox = Compilation_context.sandbox cctx in
  let cm_deps =
    Action_builder.dyn_paths_unit
      (let open Action_builder.O in
       let+ deps = Ml_kind.Dict.get deps Impl in
       List.concat_map deps ~f:(fun m ->
         [ Path.build (Obj_dir.Module.cm_file_exn obj_dir m ~kind:(Ocaml Cmi)) ]))
  in
  let ocaml_flags = Ocaml_flags.get (Compilation_context.flags cctx) (Ocaml Byte) in
  let modules = Compilation_context.modules cctx in
  let ocaml = Compilation_context.ocaml cctx in
  Super_context.add_rule
    sctx
    ~dir
    (Action_builder.With_targets.add
       ~file_targets:[ output ]
       (let open Action_builder.With_targets.O in
        Action_builder.with_no_targets cm_deps
        >>> Command.run
              (Ok ocaml.ocamlc)
              ~dir:(Path.build (Context.build_dir ctx))
              ~stdout_to:output
              [ Command.Args.dyn ocaml_flags
              ; A "-I"
              ; Path (Path.build (Obj_dir.byte_dir obj_dir))
              ; Command.Args.as_any
                  (Lib_mode.Cm_kind.Map.get
                     (Compilation_context.includes cctx)
                     (Ocaml Cmo))
              ; opens modules m
              ; A "-short-paths"
              ; A "-i"
              ; Command.Ml_kind.flag Impl
              ; Dep src
              ]
        >>| Action.Full.add_sandbox sandbox))
;;

module Alias_module = struct
  (* The alias module is an implementation detail to support wrapping library
     modules under a single toplevel name. Since OCaml doesn't have proper
     support for namespacing at the moment, in order to expose module `X` of
     library `foo` as `Foo.X`, Dune does the following:

     - it compiles x.ml to Foo__X.cmo, Foo__X.cmx, Foo__X.o, ... - it implicitly
       exposes a module alias [module X = Foo__X] to all the modules of the `foo`
       library

     The second point is achieved by implicitly opening a module containing such
     aliases for all modules of `foo` when compiling modules of `foo` via the
     `-open` option of the compiler. This module is called the alias module and
     is implicitly generated by Dune.*)

  type alias =
    { local_name : Module_name.t
    ; canonical_path : Module_name.Path.t
    ; obj_name : Module_name.Unique.t
    }

  type t =
    { aliases : alias list
    ; shadowed : Module_name.t list
    }

  let to_ml { aliases; shadowed } =
    let b = Buffer.create 16 in
    Buffer.add_string b "(* generated by dune *)\n";
    List.iter aliases ~f:(fun { canonical_path; local_name; obj_name } ->
      Printf.bprintf
        b
        "\n(** @canonical %s *)"
        (Module_name.Path.to_string canonical_path);
      Printf.bprintf
        b
        "\nmodule %s = %s\n"
        (Module_name.to_string local_name)
        (Module_name.Unique.to_name ~loc:Loc.none obj_name |> Module_name.to_string));
    List.iter shadowed ~f:(fun shadowed ->
      Printf.bprintf
        b
        "\nmodule %s = struct end\n[@@deprecated \"this module is shadowed\"]\n"
        (Module_name.to_string shadowed));
    Buffer.contents b
  ;;

  let of_modules project modules group =
    let aliases =
      Modules.Group.for_alias group
      |> List.map ~f:(fun (local_name, m) ->
        let canonical_path = Modules.With_vlib.canonical_path modules group m in
        let obj_name = Module.obj_name m in
        { canonical_path; local_name; obj_name })
    in
    let shadowed =
      if Dune_project.dune_version project < (3, 5)
      then []
      else (
        let lib_interface = Modules.Group.lib_interface group in
        match Module.kind lib_interface with
        | Alias _ -> []
        | _ -> [ Module.name (Modules.Group.alias group) ])
    in
    { aliases; shadowed }
  ;;
end

let build_alias_module cctx group =
  let alias_file () =
    let project = Compilation_context.scope cctx |> Scope.project in
    let modules = Compilation_context.modules cctx in
    Alias_module.of_modules project modules group |> Alias_module.to_ml
  in
  let alias_module = Modules.Group.alias group in
  let cctx = Compilation_context.for_alias_module cctx alias_module in
  let sctx = Compilation_context.super_context cctx in
  let file = Option.value_exn (Module.file alias_module ~ml_kind:Impl) in
  let dir = Compilation_context.dir cctx in
  let* () =
    Super_context.add_rule
      ~loc:Loc.none
      sctx
      ~dir
      (Action_builder.delayed alias_file
       |> Action_builder.write_file_dyn (Path.as_in_build_dir_exn file))
  in
  let cctx = Compilation_context.for_alias_module cctx alias_module in
  build_module cctx alias_module
;;

let root_source entries =
  let b = Buffer.create 128 in
  List.iter entries ~f:(fun name ->
    Printf.bprintf
      b
      "module %s = %s\n"
      (Module_name.to_string name)
      (Module_name.to_string name));
  Buffer.contents b
;;

let build_root_module cctx root_module =
  let entries = Compilation_context.root_module_entries cctx in
  let cctx = Compilation_context.for_root_module cctx root_module in
  let sctx = Compilation_context.super_context cctx in
  let file = Option.value_exn (Module.file root_module ~ml_kind:Impl) in
  let dir = Compilation_context.dir cctx in
  let* () =
    Super_context.add_rule
      ~loc:Loc.none
      sctx
      ~dir
      (let target = Path.as_in_build_dir_exn file in
       Action_builder.write_file_dyn
         target
         (let open Action_builder.O in
          let+ entries = entries in
          root_source entries))
  in
  build_module cctx root_module
;;

let build_all cctx =
  let for_wrapped_compat = lazy (Compilation_context.for_wrapped_compat cctx) in
  let modules = Compilation_context.modules cctx in
  Memo.parallel_iter
    (Modules.With_vlib.fold_no_vlib_with_aliases
       modules
       ~init:[]
       ~normal:(fun x acc -> `Normal x :: acc)
       ~alias:(fun group acc -> `Alias group :: acc))
    ~f:(function
      | `Alias group -> build_alias_module cctx group
      | `Normal m ->
        (match Module.kind m with
         | Alias _ -> assert false
         | Root -> build_root_module cctx m
         | Wrapped_compat ->
           let cctx = Lazy.force for_wrapped_compat in
           build_module cctx m
         | _ ->
           let cctx =
             if Modules.With_vlib.is_stdlib_alias modules m
             then
               (* XXX it would probably be simpler if the flags were just for this
                  module in the definition of the stanza *)
               Compilation_context.for_alias_module cctx m
             else cctx
           in
           build_module cctx m))
;;

let with_empty_intf ~sctx ~dir module_ =
  let name =
    Module.file module_ ~ml_kind:Impl
    |> Option.value_exn
    |> Path.set_extension ~ext:".mli"
  in
  let rule =
    Action_builder.write_file
      (Path.as_in_build_dir_exn name)
      "(* Auto-generated by Dune *)"
  in
  let+ () = Super_context.add_rule sctx ~dir rule in
  Module.add_file module_ Ml_kind.Intf (Module.File.make Dialect.ocaml name)
;;

1	open Import
2	open Memo.O
3
4	(* Arguments for the compiler to prevent it from being too clever.
5
6	The compiler creates the cmi when it thinks a .ml file has no corresponding
7	.mli. However this behavior is a bit racy and doesn't work well when the
8	extension is not .ml or when the .ml and .mli are in different directories.
9	This flags makes the compiler think there is a .mli file and will the read
10	the cmi file rather than create it. *)
11	let force_read_cmi source_file = [ "-intf-suffix"; Path.extension source_file ]	×
12
13	(* Build the cm* if the corresponding source is present, in the case of cmi if
14	the mli is not present it is added as additional target to the .cmo
15	generation *)
16
17	let opens modules m =
18	Command.Args.As (Modules.With_vlib.local_open modules m \|> Ocaml_flags.open_flags)	×
19	;;
20
21	let other_cm_files ~opaque ~cm_kind ~obj_dir =
22	List.concat_map ~f:(fun m ->	×
23	let cmi_kind = Lib_mode.Cm_kind.cmi cm_kind in	×
24	let deps = [ Path.build (Obj_dir.Module.cm_file_exn obj_dir m ~kind:cmi_kind) ] in	×
25	if Module.has m ~ml_kind:Impl && cm_kind = Ocaml Cmx && not opaque	×
26	then (	×
27	let cmx = Obj_dir.Module.cm_file_exn obj_dir m ~kind:(Ocaml Cmx) in
28	Path.build cmx :: deps)	×
29	else if Module.has m ~ml_kind:Impl && cm_kind = Melange Cmj	×
30	then (	×
31	let cmj = Obj_dir.Module.cm_file_exn obj_dir m ~kind:(Melange Cmj) in
32	Path.build cmj :: deps)	×
33	else deps)	×
34	;;
35
36	let copy_interface ~sctx ~dir ~obj_dir ~cm_kind m =
37	(* symlink the .cmi into the public interface directory *)
38	Memo.when_	×
39	(Module.visibility m <> Visibility.Private	×
40	&& Obj_dir.need_dedicated_public_dir obj_dir)	×
41	(fun () ->
42	let cmi_kind = Lib_mode.Cm_kind.cmi cm_kind in	×
43	Super_context.add_rule	×
44	sctx
45	~dir
46	(Action_builder.symlink
47	~src:(Path.build (Obj_dir.Module.cm_file_exn obj_dir m ~kind:cmi_kind))	×
48	~dst:(Obj_dir.Module.cm_public_file_exn obj_dir m ~kind:cmi_kind)))	×
49	;;
50
51	let melange_args (cctx : Compilation_context.t) (cm_kind : Lib_mode.Cm_kind.t) module_ =
52	match cm_kind with	×
53	\| Ocaml (Cmi \| Cmo \| Cmx) \| Melange Cmi -> []	×
54	\| Melange Cmj ->	×
55	let bs_package_name, bs_package_output =
56	let package_output =
57	Module.file ~ml_kind:Impl module_ \|> Option.value_exn \|> Path.parent_exn	×
58	in
59	match Compilation_context.melange_package_name cctx with	×
60	\| None -> [], package_output	×
61	\| Some lib_name ->	×
62	let dir =
63	let package_output = Path.as_in_build_dir_exn package_output in
64	let lib_root_dir = Path.build (Compilation_context.dir cctx) in	×
65	let src_dir = Path.build package_output in	×
66	let build_dir =	×
67	Compilation_context.super_context cctx
68	\|> Super_context.context	×
69	\|> Context.build_dir	×
70	in
71	Path.drop_prefix_exn src_dir ~prefix:lib_root_dir	×
72	\|> Path.Local.to_string	×
73	\|> Path.Build.relative build_dir	×
74	in
75	( [ Command.Args.A "--bs-package-name"; A (Lib_name.to_string lib_name) ]	×
76	, Path.build dir )	×
77	in
78	Command.Args.A "--bs-stop-after-cmj"
79	:: A "--bs-package-output"
80	:: Command.Args.Path bs_package_output
81	:: A "--bs-module-name"
82	:: A (Melange.js_basename module_)	×
83	:: bs_package_name
84	;;
85
86	let build_cm
87	cctx
88	~force_write_cmi
89	~precompiled_cmi
90	~cm_kind
91	(m : Module.t)
92	~(phase : Fdo.phase option)
93	=
94	if force_write_cmi && precompiled_cmi	×
95	then Code_error.raise "force_read_cmi and precompiled_cmi are mutually exclusive" [];	×
96	let sctx = Compilation_context.super_context cctx in	×
97	let dir = Compilation_context.dir cctx in	×
98	let obj_dir = Compilation_context.obj_dir cctx in	×
99	let ctx = Super_context.context sctx in	×
100	let mode = Lib_mode.of_cm_kind cm_kind in	×
101	let sandbox =	×
102	let default = Compilation_context.sandbox cctx in
103	match Module.kind m with	×
104	\| Root ->	×
105	(* This is need to guarantee that no local modules shadow the modules
106	referenced by the root module *)
107	Sandbox_config.needs_sandboxing
108	\| _ -> default	×
109	in
110	let ocaml = Compilation_context.ocaml cctx in
UNCOV 111	let* compiler =	×
112	match mode with
113	\| Melange ->	×
114	let loc = Compilation_context.loc cctx in
115	let+ melc = Melange_binary.melc sctx ~loc ~dir in	×
116	Some melc	×
117	\| Ocaml mode ->	×
118	Memo.return	×
119	(let compiler = Ocaml_toolchain.compiler ocaml mode in
120	(* TODO one day remove this silly optimization *)
121	match compiler with	×
122	\| Ok _ as s -> Some s	×
123	\| Error _ -> None)	×
124	in
125	(let open Option.O in	×
126	let* compiler = compiler in
127	let ml_kind = Lib_mode.Cm_kind.source cm_kind in	×
128	let+ src = Module.file m ~ml_kind in	×
129	let dst = Obj_dir.Module.cm_file_exn obj_dir m ~kind:cm_kind in	×
130	let obj =	×
131	Obj_dir.Module.obj_file obj_dir m ~kind:(Ocaml Cmx) ~ext:ocaml.lib_config.ext_obj
132	in
133	let open Memo.O in	×
134	let* extra_args, extra_deps, other_targets =
135	if precompiled_cmi
136	then Memo.return (force_read_cmi src, [], [])	×
137	else (	×
138	(* If we're compiling an implementation, then the cmi is present *)
139	let public_vlib_module = Module.kind m = Impl_vmodule in	×
140	match phase with
141	\| Some Emit -> Memo.return ([], [], [])	×
142	\| Some Compile \| Some All \| None ->	×
143	(match cm_kind, Module.file m ~ml_kind:Intf, public_vlib_module with	×
144	(* If there is no mli, [ocamlY -c file.ml] produces both the .cmY and
145	.cmi. We choose to use ocamlc to produce the cmi and to produce the
146	cmx we have to wait to avoid race conditions. *)
147	\| (Ocaml Cmo \| Melange Cmj), None, false ->	×
148	if force_write_cmi
149	then Memo.return ([ "-intf-suffix"; ".dummy-ignore-mli" ], [], [])	×
150	else
151	let+ () = copy_interface ~dir ~obj_dir ~sctx ~cm_kind m in	×
152	let cmi_kind = Lib_mode.Cm_kind.cmi cm_kind in	×
153	[], [], [ Obj_dir.Module.cm_file_exn obj_dir m ~kind:cmi_kind ]	×
154	\| (Ocaml Cmo \| Melange Cmj), None, true	×
155	\| (Ocaml (Cmo \| Cmx) \| Melange Cmj), _, _ ->	×
156	let cmi_kind = Lib_mode.Cm_kind.cmi cm_kind in
157	Memo.return	×
158	( force_read_cmi src	×
159	, [ Path.build (Obj_dir.Module.cm_file_exn obj_dir m ~kind:cmi_kind) ]	×
160	, [] )
161	\| (Ocaml Cmi \| Melange Cmi), _, _ ->	×
162	let+ () = copy_interface ~dir ~obj_dir ~sctx ~cm_kind m in	×
163	[], [], []))	×
164	in
165	let other_targets =	×
166	match cm_kind with
167	\| Ocaml (Cmi \| Cmo) \| Melange (Cmi \| Cmj) -> other_targets	×
168	\| Ocaml Cmx ->	×
169	(match phase with
170	\| Some Compile ->	×
171	let linear =
172	Obj_dir.Module.obj_file obj_dir m ~kind:(Ocaml Cmx) ~ext:Fdo.linear_ext
173	in
174	linear :: other_targets	×
175	\| Some Emit -> other_targets	×
176	\| Some All \| None -> obj :: other_targets)	×
177	in
178	let opaque = Compilation_context.opaque cctx in
179	let other_cm_files =	×
180	let dep_graph = Ml_kind.Dict.get (Compilation_context.dep_graphs cctx) ml_kind in	×
181	let module_deps = Dep_graph.deps_of dep_graph m in	×
182	Action_builder.dyn_paths_unit	×
183	(Action_builder.map module_deps ~f:(other_cm_files ~opaque ~cm_kind ~obj_dir))	×
184	in
185	let other_targets, cmt_args =
186	match cm_kind with
187	\| Ocaml Cmx -> other_targets, Command.Args.empty	×
188	\| Ocaml (Cmi \| Cmo) \| Melange (Cmi \| Cmj) ->	×
189	if Compilation_context.bin_annot cctx
190	then (	×
191	let fn =
192	Option.value_exn (Obj_dir.Module.cmt_file obj_dir m ~cm_kind ~ml_kind)	×
193	in
194	let annots =	×
195	[ "-bin-annot" ]
196	@
197	if Version.supports_bin_annot_occurrences ocaml.version
198	then [ "-bin-annot-occurrences" ]	×
199	else []	×
200	in
201	fn :: other_targets, As annots)
202	else other_targets, Command.Args.empty	×
203	in
204	let opaque_arg : _ Command.Args.t =
205	let intf_only = cm_kind = Ocaml Cmi && not (Module.has m ~ml_kind:Impl) in	×
206	if opaque \|\| (intf_only && Ocaml.Version.supports_opaque_for_mli ocaml.version)	×
207	then A "-opaque"	×
208	else Command.Args.empty	×
209	in
210	let flags, sandbox =
211	let flags =
212	Command.Args.dyn (Ocaml_flags.get (Compilation_context.flags cctx) mode)	×
213	in
214	match Module.pp_flags m with	×
215	\| None -> flags, sandbox	×
216	\| Some (pp, sandbox') ->	×
217	S [ flags; Command.Args.dyn pp ], Sandbox_config.inter sandbox sandbox'	×
218	in
219	let output =
220	match phase with
221	\| Some Compile -> dst	×
222	\| Some Emit -> obj	×
223	\| Some All \| None -> dst	×
224	in
225	let src =
226	match phase with
227	\| Some Emit ->	×
228	let linear_fdo =
229	Obj_dir.Module.obj_file obj_dir m ~kind:(Ocaml Cmx) ~ext:Fdo.linear_fdo_ext
230	in
231	Path.build linear_fdo	×
232	\| Some Compile \| Some All \| None -> src	×
233	in
234	let opens =
235	let modules = Compilation_context.modules cctx in
236	opens modules m	×
237	in
238	let obj_dirs =
239	Obj_dir.all_obj_dirs obj_dir ~mode
240	\|> List.concat_map ~f:(fun p -> [ Command.Args.A "-I"; Path (Path.build p) ])	×
241	in
242	Super_context.add_rule	×
243	sctx
244	~dir:
245	(let dune_version =
246	Compilation_context.scope cctx \|> Scope.project \|> Dune_project.dune_version	×
247	in
248	(* TODO DUNE4 get rid of the old behavior *)
249	if dune_version >= (3, 7) then dir else Context.build_dir ctx)	×
250	?loc:(Compilation_context.loc cctx)	×
251	(let open Action_builder.With_targets.O in
252	Action_builder.with_no_targets (Action_builder.paths extra_deps)	×
253	>>> Action_builder.with_no_targets other_cm_files	×
254	>>> Command.run	×
255	~dir:(Path.build (Context.build_dir ctx))	×
256	compiler
257	[ flags
258	; cmt_args
259	; Command.Args.S obj_dirs
260	; Command.Args.as_any	×
261	(Lib_mode.Cm_kind.Map.get (Compilation_context.includes cctx) cm_kind)	×
262	; As extra_args
263	; S (melange_args cctx cm_kind m)	×
264	; A "-no-alias-deps"
265	; opaque_arg
266	; As (Fdo.phase_flags phase)	×
267	; opens
268	; As
269	(match Compilation_context.stdlib cctx with
270	\| None -> []	×
271	\| Some _ ->	×
272	(* XXX why aren't these just normal library flags? *)
273	[ "-nopervasives"; "-nostdlib" ])
274	; A "-o"
275	; Target output
276	; A "-c"
277	; Command.Ml_kind.flag ml_kind	×
278	; Dep src
279	; Hidden_targets other_targets
280	]
281	>>\| Action.Full.add_sandbox sandbox))	×
282	\|> Memo.Option.iter ~f:Fun.id
283	;;
284
285	let build_module ?(force_write_cmi = false) ?(precompiled_cmi = false) cctx m =	×
286	let open Memo.O in	×
287	let { Lib_mode.Map.ocaml; melange } = Compilation_context.modes cctx in
288	let build_cm = build_cm cctx m ~force_write_cmi ~precompiled_cmi in	×
289	let* () =	×
290	Memo.when_ (ocaml.byte \|\| ocaml.native) (fun () ->	×
291	let* () = build_cm ~cm_kind:(Ocaml Cmo) ~phase:None	×
292	and* () =
293	let ctx = Compilation_context.context cctx in
294	let ocaml = Compilation_context.ocaml cctx in	×
295	let can_split =	×
296	Ocaml.Version.supports_split_at_emit ocaml.version	×
297	\|\| Ocaml_config.is_dev_version ocaml.ocaml_config	×
298	in
299	match Context.fdo_target_exe ctx, can_split with	×
300	\| None, _ -> build_cm ~cm_kind:(Ocaml Cmx) ~phase:None	×
301	\| Some _, false -> build_cm ~cm_kind:(Ocaml Cmx) ~phase:(Some All)	×
302	\| Some _, true ->	×
303	build_cm ~cm_kind:(Ocaml Cmx) ~phase:(Some Compile)
304	>>> Fdo.opt_rule cctx m	×
305	>>> build_cm ~cm_kind:(Ocaml Cmx) ~phase:(Some Emit)	×
306	and* () =
307	Memo.when_ (not precompiled_cmi) (fun () ->	×
308	build_cm ~cm_kind:(Ocaml Cmi) ~phase:None)	×
309	in
310	let obj_dir = Compilation_context.obj_dir cctx in	×
311	match Obj_dir.Module.cm_file obj_dir m ~kind:(Ocaml Cmo) with	×
312	\| None -> Memo.return ()	×
313	\| Some src ->	×
314	Compilation_context.js_of_ocaml cctx
315	\|> Memo.Option.iter ~f:(fun in_context ->	×
316	(* Build .cmo.js )
317	let sctx = Compilation_context.super_context cctx in	×
318	let dir = Compilation_context.dir cctx in	×
319	let action_with_targets =	×
320	Jsoo_rules.build_cm
321	sctx
322	~dir
323	~in_context
324	~src:(Path.build src)	×
325	~obj_dir
326	~config:None
327	in
328	Super_context.add_rule sctx ~dir action_with_targets))	×
329	in
330	Memo.when_ melange (fun () ->	×
331	let* () = build_cm ~cm_kind:(Melange Cmj) ~phase:None in	×
332	Memo.when_ (not precompiled_cmi) (fun () ->	×
333	build_cm ~cm_kind:(Melange Cmi) ~phase:None))	×
334	;;
335
336	let ocamlc_i ~deps cctx (m : Module.t) ~output =
337	let sctx = Compilation_context.super_context cctx in	×
338	let obj_dir = Compilation_context.obj_dir cctx in	×
339	let dir = Compilation_context.dir cctx in	×
340	let ctx = Super_context.context sctx in	×
341	let src = Option.value_exn (Module.file m ~ml_kind:Impl) in	×
342	let sandbox = Compilation_context.sandbox cctx in	×
343	let cm_deps =	×
344	Action_builder.dyn_paths_unit
345	(let open Action_builder.O in
346	let+ deps = Ml_kind.Dict.get deps Impl in	×
347	List.concat_map deps ~f:(fun m ->	×
348	[ Path.build (Obj_dir.Module.cm_file_exn obj_dir m ~kind:(Ocaml Cmi)) ]))	×
349	in
350	let ocaml_flags = Ocaml_flags.get (Compilation_context.flags cctx) (Ocaml Byte) in	×
351	let modules = Compilation_context.modules cctx in	×
352	let ocaml = Compilation_context.ocaml cctx in	×
353	Super_context.add_rule	×
354	sctx
355	~dir
356	(Action_builder.With_targets.add	×
357	~file_targets:[ output ]
358	(let open Action_builder.With_targets.O in
359	Action_builder.with_no_targets cm_deps	×
360	>>> Command.run	×
361	(Ok ocaml.ocamlc)
362	~dir:(Path.build (Context.build_dir ctx))	×
363	~stdout_to:output
364	[ Command.Args.dyn ocaml_flags	×
365	; A "-I"
366	; Path (Path.build (Obj_dir.byte_dir obj_dir))	×
367	; Command.Args.as_any	×
368	(Lib_mode.Cm_kind.Map.get	×
369	(Compilation_context.includes cctx)	×
370	(Ocaml Cmo))
371	; opens modules m	×
372	; A "-short-paths"
373	; A "-i"
374	; Command.Ml_kind.flag Impl	×
375	; Dep src
376	]
377	>>\| Action.Full.add_sandbox sandbox))	×
378	;;
379
380	module Alias_module = struct
381	(* The alias module is an implementation detail to support wrapping library
382	modules under a single toplevel name. Since OCaml doesn't have proper
383	support for namespacing at the moment, in order to expose module `X` of
384	library `foo` as `Foo.X`, Dune does the following:
385
386	- it compiles x.ml to Foo__X.cmo, Foo__X.cmx, Foo__X.o, ... - it implicitly
387	exposes a module alias [module X = Foo__X] to all the modules of the `foo`
388	library
389
390	The second point is achieved by implicitly opening a module containing such
391	aliases for all modules of `foo` when compiling modules of `foo` via the
392	`-open` option of the compiler. This module is called the alias module and
393	is implicitly generated by Dune.*)
394
395	type alias =
396	{ local_name : Module_name.t
397	; canonical_path : Module_name.Path.t
398	; obj_name : Module_name.Unique.t
399	}
400
401	type t =
402	{ aliases : alias list
403	; shadowed : Module_name.t list
404	}
405
406	let to_ml { aliases; shadowed } =
407	let b = Buffer.create 16 in	×
408	Buffer.add_string b "(* generated by dune *)\n";	×
409	List.iter aliases ~f:(fun { canonical_path; local_name; obj_name } ->	×
410	Printf.bprintf	×
411	b
412	"\n(** @canonical %s *)"
413	(Module_name.Path.to_string canonical_path);	×
414	Printf.bprintf	×
415	b
416	"\nmodule %s = %s\n"
417	(Module_name.to_string local_name)	×
418	(Module_name.Unique.to_name ~loc:Loc.none obj_name \|> Module_name.to_string));	×
419	List.iter shadowed ~f:(fun shadowed ->	×
420	Printf.bprintf	×
421	b
422	"\nmodule %s = struct end\n[@@deprecated \"this module is shadowed\"]\n"
423	(Module_name.to_string shadowed));	×
424	Buffer.contents b	×
425	;;
426
427	let of_modules project modules group =
428	let aliases =	×
429	Modules.Group.for_alias group
430	\|> List.map ~f:(fun (local_name, m) ->	×
431	let canonical_path = Modules.With_vlib.canonical_path modules group m in	×
432	let obj_name = Module.obj_name m in	×
433	{ canonical_path; local_name; obj_name })	×
434	in
435	let shadowed =	×
436	if Dune_project.dune_version project < (3, 5)	×
437	then []	×
438	else (	×
439	let lib_interface = Modules.Group.lib_interface group in
440	match Module.kind lib_interface with	×
441	\| Alias _ -> []	×
442	\| _ -> [ Module.name (Modules.Group.alias group) ])	×
443	in
444	{ aliases; shadowed }
445	;;
446	end
447
448	let build_alias_module cctx group =
449	let alias_file () =	×
450	let project = Compilation_context.scope cctx \|> Scope.project in	×
451	let modules = Compilation_context.modules cctx in	×
452	Alias_module.of_modules project modules group \|> Alias_module.to_ml	×
453	in
454	let alias_module = Modules.Group.alias group in
455	let cctx = Compilation_context.for_alias_module cctx alias_module in	×
456	let sctx = Compilation_context.super_context cctx in	×
457	let file = Option.value_exn (Module.file alias_module ~ml_kind:Impl) in	×
458	let dir = Compilation_context.dir cctx in	×
459	let* () =	×
UNCOV 460	Super_context.add_rule	×
461	~loc:Loc.none
462	sctx
463	~dir
464	(Action_builder.delayed alias_file
465	\|> Action_builder.write_file_dyn (Path.as_in_build_dir_exn file))	×
466	in
467	let cctx = Compilation_context.for_alias_module cctx alias_module in	×
468	build_module cctx alias_module	×
469	;;
470
471	let root_source entries =
472	let b = Buffer.create 128 in	×
473	List.iter entries ~f:(fun name ->	×
474	Printf.bprintf	×
475	b
476	"module %s = %s\n"
477	(Module_name.to_string name)	×
478	(Module_name.to_string name));	×
479	Buffer.contents b	×
480	;;
481
482	let build_root_module cctx root_module =
483	let entries = Compilation_context.root_module_entries cctx in	×
484	let cctx = Compilation_context.for_root_module cctx root_module in	×
485	let sctx = Compilation_context.super_context cctx in	×
486	let file = Option.value_exn (Module.file root_module ~ml_kind:Impl) in	×
487	let dir = Compilation_context.dir cctx in	×
488	let* () =	×
UNCOV 489	Super_context.add_rule	×
490	~loc:Loc.none
491	sctx
492	~dir
493	(let target = Path.as_in_build_dir_exn file in
494	Action_builder.write_file_dyn	×
495	target
496	(let open Action_builder.O in
497	let+ entries = entries in
498	root_source entries))	×
499	in
500	build_module cctx root_module	×
501	;;
502
503	let build_all cctx =
504	let for_wrapped_compat = lazy (Compilation_context.for_wrapped_compat cctx) in	×
505	let modules = Compilation_context.modules cctx in
506	Memo.parallel_iter	×
507	(Modules.With_vlib.fold_no_vlib_with_aliases	×
508	modules
509	~init:[]
510	~normal:(fun x acc -> `Normal x :: acc)	×
511	~alias:(fun group acc -> `Alias group :: acc))	×
512	~f:(function
513	\| `Alias group -> build_alias_module cctx group	×
514	\| `Normal m ->	×
515	(match Module.kind m with
516	\| Alias _ -> assert false
517	\| Root -> build_root_module cctx m	×
518	\| Wrapped_compat ->	×
519	let cctx = Lazy.force for_wrapped_compat in
520	build_module cctx m	×
521	\| _ ->	×
522	let cctx =
523	if Modules.With_vlib.is_stdlib_alias modules m
524	then
525	(* XXX it would probably be simpler if the flags were just for this
526	module in the definition of the stanza *)
527	Compilation_context.for_alias_module cctx m	×
528	else cctx	×
529	in
530	build_module cctx m))
531	;;
532
533	let with_empty_intf ~sctx ~dir module_ =
534	let name =	×
535	Module.file module_ ~ml_kind:Impl
536	\|> Option.value_exn	×
537	\|> Path.set_extension ~ext:".mli"	×
538	in
539	let rule =	×
540	Action_builder.write_file
541	(Path.as_in_build_dir_exn name)	×
542	"(* Auto-generated by Dune *)"
543	in
544	let+ () = Super_context.add_rule sctx ~dir rule in	×
545	Module.add_file module_ Ml_kind.Intf (Module.File.make Dialect.ocaml name)	×
546	;;

ocaml / dune / 28906

Source File Press 'n' to go to next uncovered line, 'b' for previous

Source File
Press 'n' to go to next uncovered line, 'b' for previous