Skip to content

Commit

Permalink
feature: enable (include_subdirs qualified)
Browse files Browse the repository at this point in the history
Signed-off-by: Rudi Grinberg <me@rgrinberg.com>

ps-id: f0bdd789-87c5-4047-b418-47cdaf7749ae
  • Loading branch information
rgrinberg committed Dec 5, 2022
1 parent ab19b38 commit a8b837a
Show file tree
Hide file tree
Showing 69 changed files with 1,652 additions and 664 deletions.
2 changes: 1 addition & 1 deletion bin/describe.ml
Original file line number Diff line number Diff line change
Expand Up @@ -262,7 +262,7 @@ module Crawl = struct
Memo.return
@@
match Module.kind unit with
| Alias ->
| Alias _ ->
(* TODO: handle Alias modules, that are generated by dune. They are
currently associated to no ocamldep-related rules. *)
Action_builder.return no_deps
Expand Down
3 changes: 1 addition & 2 deletions bin/ocaml_merlin.ml
Original file line number Diff line number Diff line change
Expand Up @@ -78,14 +78,13 @@ end = struct
let load_merlin_file file =
(* We search for an appropriate merlin configuration in the current
directory and its parents *)
let filename = String.lowercase_ascii (Path.Build.basename file) in
let rec find_closest path =
match
get_merlin_files_paths path
|> List.find_map ~f:(fun file_path ->
match Merlin.Processed.load_file file_path with
| Error msg -> Some (Merlin_conf.make_error msg)
| Ok config -> Merlin.Processed.get config ~filename)
| Ok config -> Merlin.Processed.get config ~file)
with
| Some p -> Some p
| None -> (
Expand Down
4 changes: 1 addition & 3 deletions bin/top.ml
Original file line number Diff line number Diff line change
Expand Up @@ -190,9 +190,7 @@ module Module = struct
let+ (pp, ppx), files_to_load = Memo.fork_and_join pps files_to_load in
let code =
let modules = Dune_rules.Compilation_context.modules cctx in
let opens_ =
Dune_rules.Module_compilation.open_modules modules module_
in
let opens_ = Dune_rules.Modules.local_open modules module_ in
List.map opens_ ~f:(fun name ->
sprintf "open %s" (Dune_rules.Module_name.to_string name))
in
Expand Down
12 changes: 8 additions & 4 deletions src/dune_rules/action_unexpanded.ml
Original file line number Diff line number Diff line change
Expand Up @@ -370,11 +370,12 @@ end = struct
end
end

let rec expand (t : Dune_lang.Action.t) : Action.t Action_expander.t =
let rec expand (t : Dune_lang.Action.t) ~context : Action.t Action_expander.t =
let module A = Action_expander in
let module E = Action_expander.E in
let open Action_expander.O in
let module O (* [O] for "outcome" *) = Action in
let expand = expand ~context in
let expand_run prog args =
let+ args = A.all (List.map args ~f:E.strings)
and+ prog, more_args = E.prog_and_args prog in
Expand Down Expand Up @@ -434,7 +435,7 @@ let rec expand (t : Dune_lang.Action.t) : Action.t Action_expander.t =
| Copy_and_add_line_directive (x, y) ->
let+ x = E.dep x
and+ y = E.target y in
Copy_line_directive.action x y
Copy_line_directive.action context ~src:x ~dst:y
| System x ->
let+ x = E.string x in
O.System x
Expand Down Expand Up @@ -485,8 +486,9 @@ let expand_no_targets t ~loc ~deps:deps_written_by_user ~expander ~what =
Expander.set_expanding_what expander (User_action_without_targets { what })
in
let* { Action_builder.With_targets.build; targets } =
let context = Expander.context expander in
Action_builder.of_memo
(Action_expander.run (expand t) ~targets_dir:None ~expander)
(Action_expander.run (expand ~context t) ~targets_dir:None ~expander)
in
if not (Targets.is_empty targets) then
User_error.raise ~loc
Expand Down Expand Up @@ -529,7 +531,9 @@ let expand t ~loc ~deps:deps_written_by_user ~targets_dir
Expander.set_expanding_what expander (User_action targets_written_by_user)
in
let+! { Action_builder.With_targets.build; targets } =
Action_expander.run (expand t) ~targets_dir:(Some targets_dir) ~expander
let context = Expander.context expander in
Action_expander.run (expand ~context t) ~targets_dir:(Some targets_dir)
~expander
in
let targets =
match (targets_written_by_user : _ Targets_spec.t) with
Expand Down
7 changes: 4 additions & 3 deletions src/dune_rules/buildable_rules.ml
Original file line number Diff line number Diff line change
@@ -1,20 +1,21 @@
open Import
open Memo.O

let gen_select_rules t ~dir compile_info =
let gen_select_rules sctx ~dir compile_info =
let open Memo.O in
Lib.Compile.resolved_selects compile_info
|> Resolve.Memo.read_memo
>>= Memo.parallel_iter
~f:(fun { Lib.Compile.Resolved_select.dst_fn; src_fn } ->
let dst = Path.Build.relative dir dst_fn in
Super_context.add_rule t ~dir
Super_context.add_rule sctx ~dir
(Action_builder.with_file_targets ~file_targets:[ dst ]
(let open Action_builder.O in
let* src_fn = Resolve.read src_fn in
let src = Path.build (Path.Build.relative dir src_fn) in
let+ () = Action_builder.path src in
Action.Full.make (Copy_line_directive.action src dst))))
let context = Super_context.context sctx in
Action.Full.make (Copy_line_directive.action context ~src ~dst))))

let with_lib_deps (t : Context.t) compile_info ~dir ~f =
let prefix =
Expand Down
73 changes: 65 additions & 8 deletions src/dune_rules/copy_line_directive.ml
Original file line number Diff line number Diff line change
@@ -1,54 +1,111 @@
open Import

module DB = struct
module Persistent = Dune_util.Persistent.Make (struct
type nonrec t = Path.Build.t Path.Build.Table.t

let name = "COPY-LINE-DIRECTIVE-MAP"

let version = 1

let to_dyn = Path.Build.Table.to_dyn Path.Build.to_dyn
end)

let needs_dumping = ref false

let file = Path.relative Path.build_dir ".copy-db"

let t =
(* This mutable table is safe: it's only observed by [$ dune ocaml merlin] *)
lazy
(match Persistent.load file with
| None -> Path.Build.Table.create 128
| Some t -> t)

let dump () =
if !needs_dumping && Path.build_dir_exists () then (
needs_dumping := false;
Persistent.dump file (Lazy.force t))

let () = at_exit dump

let rec follow_while path ~f =
let t = Lazy.force t in
match Path.Build.Table.find t path with
| None -> None
| Some p -> (
match f p with
| None -> follow_while p ~f
| Some p -> Some p)

let set ~src ~dst =
let t = Lazy.force t in
needs_dumping := true;
Path.Build.Table.set t src dst
end

let line_directive ~filename:fn ~line_number =
let directive =
if Foreign_language.has_foreign_extension ~fn then "line" else ""
in
sprintf "#%s %d %S\n" directive line_number fn

module Spec = struct
type ('path, 'target) t = 'path * 'target
type merlin =
| Yes
| No

let bool_of_merlin = function
| Yes -> true
| No -> false

type ('path, 'target) t = 'path * 'target * merlin

let name = "copy-line-directive"

let version = 1

let bimap (src, dst) f g = (f src, g dst)
let bimap (src, dst, merlin) f g = (f src, g dst, merlin)

let is_useful_to ~distribute:_ ~memoize = memoize

let encode (src, dst) path target : Dune_lang.t =
let encode (src, dst, merlin) path target : Dune_lang.t =
List
[ Dune_lang.atom_or_quoted_string "copy-line-directive"
; path src
; target dst
; Dune_lang.atom_or_quoted_string (Bool.to_string (bool_of_merlin merlin))
]

let action (src, dst) ~ectx:_ ~eenv:_ =
let action (src, dst, merlin) ~ectx:_ ~eenv:_ =
Io.with_file_in src ~f:(fun ic ->
Path.build dst
|> Io.with_file_out ~f:(fun oc ->
let fn = Path.drop_optional_build_context_maybe_sandboxed src in
output_string oc
(line_directive ~filename:(Path.to_string fn) ~line_number:1);
Io.copy_channels ic oc));
(match merlin with
| No -> ()
| Yes ->
Path.as_in_build_dir src |> Option.iter ~f:(fun src -> DB.set ~src ~dst));
Fiber.return ()
end

let action src dst =
let action (context : Context.t) ~src ~dst =
let module M = struct
type path = Path.t

type target = Path.Build.t

module Spec = Spec

let v = (src, dst)
let v = (src, dst, if context.merlin then Spec.Yes else No)
end in
Action.Extension (module M)

let builder ~src ~dst =
let builder context ~src ~dst =
let open Action_builder.O in
Action_builder.with_file_targets ~file_targets:[ dst ]
(Action_builder.path src
>>> Action_builder.return (Action.Full.make (action src dst)))
>>> Action_builder.return (Action.Full.make (action context ~src ~dst)))
11 changes: 9 additions & 2 deletions src/dune_rules/copy_line_directive.mli
Original file line number Diff line number Diff line change
@@ -1,6 +1,13 @@
open Import

val action : Path.t -> Path.Build.t -> Action.t
module DB : sig
val follow_while : Path.Build.t -> f:(Path.Build.t -> 'a option) -> 'a option
end

val action : Context.t -> src:Path.t -> dst:Path.Build.t -> Action.t

val builder :
src:Path.t -> dst:Path.Build.t -> Action.Full.t Action_builder.With_targets.t
Context.t
-> src:Path.t
-> dst:Path.Build.t
-> Action.Full.t Action_builder.With_targets.t
17 changes: 13 additions & 4 deletions src/dune_rules/dep_rules.ml
Original file line number Diff line number Diff line change
Expand Up @@ -43,17 +43,23 @@ let ooi_deps { vimpl; sctx; dir; obj_dir; modules = _; stdlib = _; sandbox = _ }
in
read

let deps_of_module md ~ml_kind m =
let deps_of_module ({ modules; _ } as md) ~ml_kind m =
match Module.kind m with
| Wrapped_compat ->
let modules = md.modules in
let interface_module =
match Modules.lib_interface modules with
| Some m -> m
| None -> Modules.compat_for_exn modules m
in
Action_builder.return (List.singleton interface_module) |> Memo.return
| _ -> Ocamldep.deps_of md ~ml_kind m
| _ -> (
let+ deps = Ocamldep.deps_of md ~ml_kind m in
match Modules.alias_for modules m with
| [] -> deps
| aliases ->
let open Action_builder.O in
let+ deps = deps in
aliases @ deps)

let deps_of_vlib_module ({ obj_dir; vimpl; dir; sctx; _ } as md) ~ml_kind m =
let vimpl = Option.value_exn vimpl in
Expand Down Expand Up @@ -82,8 +88,11 @@ let deps_of_vlib_module ({ obj_dir; vimpl; dir; sctx; _ } as md) ~ml_kind m =
let rec deps_of md ~ml_kind (m : Modules.Sourced_module.t) =
let is_alias =
match m with
| Imported_from_vlib m | Normal m -> Module.kind m = Alias
| Impl_of_virtual_module _ -> false
| Imported_from_vlib m | Normal m -> (
match Module.kind m with
| Alias _ -> true
| _ -> false)
in
if is_alias then Memo.return (Action_builder.return [])
else
Expand Down
15 changes: 10 additions & 5 deletions src/dune_rules/dune_file.ml
Original file line number Diff line number Diff line change
Expand Up @@ -2143,11 +2143,16 @@ module Include_subdirs = struct
| Include of qualification

let decode ~enable_qualified =
let opts_list =
[ ("no", No); ("unqualified", Include Unqualified) ]
@ if enable_qualified then [ ("qualified", Include Qualified) ] else []
in
enum opts_list
sum
[ ("no", return No)
; ("unqualified", return (Include Unqualified))
; ( "qualified"
, let+ () =
if enable_qualified then return ()
else Syntax.since Stanza.syntax (3, 7)
in
Include Qualified )
]
end

module Library_redirect = struct
Expand Down
Loading

0 comments on commit a8b837a

Please sign in to comment.