Skip to content

Commit

Permalink
Remove various helper functions from Action_builder modules
Browse files Browse the repository at this point in the history 
Signed-off-by: Andrey Mokhov <amokhov@janestreet.com>
  • Loading branch information
@snowleopard
snowleopard committed Nov 9, 2023
1 parent 5633ee4 commit d93a5d2
Show file tree
Hide file tree
Showing 4 changed files with 174 additions and 566 deletions.
308 changes: 18 additions & 290 deletions src/dune_engine/action_builder.ml
View file
Original file line number Diff line number Diff line change
@@ -1,77 +1,38 @@
open Import
include Action_builder0
open O

open struct
module List = Stdune.List
end

let register_action_deps : type a. a eval_mode -> Dep.Set.t -> a Dep.Map.t Memo.t =
let record_action_deps : type m. m eval_mode -> Dep.Set.t -> m Memo.t =
fun mode deps ->
match mode with
| Eager -> Build_system.build_deps deps
| Lazy -> Memo.return deps
;;

let dyn_memo_deps deps =
let record (deps : Dep.Set.t) =
of_thunk
{ f =
(fun mode ->
let open Memo.O in
let* deps, paths = deps in
let+ deps = register_action_deps mode deps in
paths, deps)
let open Memo.O in
let+ deps = record_action_deps mode deps in
(), deps)
}
;;

let deps d = dyn_memo_deps (Memo.return (d, ()))
let dep d = deps (Dep.Set.singleton d)

let dyn_deps t =
of_thunk
{ f =
(fun mode ->
let open Memo.O in
let* (x, deps), deps_x = run t mode in
let+ deps = register_action_deps mode deps in
x, Deps_or_facts.union mode deps deps_x)
}
;;

let path p = deps (Dep.Set.singleton (Dep.file p))
let paths ps = deps (Dep.Set.of_files ps)
let path_set ps = deps (Dep.Set.of_files_set ps)

let paths_matching
: type a. File_selector.t -> a eval_mode -> (Path.Set.t * a Dep.Map.t) Memo.t
=
let paths_matching : type m. File_selector.t -> m eval_mode -> (unit * m) Memo.t =
fun g mode ->
let open Memo.O in
match mode with
| Eager ->
let+ files = Build_system.build_pred g in
( Path.Map.keys (Dep.Fact.Files.paths files) |> Path.Set.of_list
, Dep.Map.singleton (Dep.file_selector g) (Dep.Fact.file_selector g files) )
| Lazy ->
let+ files = Build_system.eval_pred g in
files, Dep.Set.singleton (Dep.file_selector g)
let+ facts = Build_system.build_pred g in
(), Dep.Facts.singleton (Dep.file_selector g) (Dep.Fact.file_selector g facts)
| Lazy -> Memo.return ((), Dep.Set.singleton (Dep.file_selector g))
;;

let paths_matching ~loc:_ g = of_thunk { f = (fun mode -> paths_matching g mode) }
let paths_matching_unit ~loc g = ignore (paths_matching ~loc g)
let dyn_paths paths = dyn_deps (paths >>| fun (x, paths) -> x, Dep.Set.of_files paths)
let dyn_paths_unit paths = dyn_deps (paths >>| fun paths -> (), Dep.Set.of_files paths)

let dyn_path_set paths =
dyn_deps (paths >>| fun (x, paths) -> x, Dep.Set.of_files_set paths)
;;

let dyn_path_set_reuse paths =
dyn_deps (paths >>| fun paths -> paths, Dep.Set.of_files_set paths)
;;

let env_var s = deps (Dep.Set.singleton (Dep.env s))
let alias a = dep (Dep.alias a)

let contents =
let read_file =
Expand All @@ -86,256 +47,23 @@ let contents =
fun p ->
of_thunk
{ f =
(fun _mode ->
let open Memo.O in
let+ x = read_file p in
x, Dep.Map.empty)
(fun mode ->
let open Memo.O in
let+ x = read_file p in
x, Deps_or_facts.empty mode)
}
;;

let lines_of p = contents p >>| String.split_lines

let read_sexp p =
let+ s = contents p in
Dune_sexp.Parser.parse_string s ~fname:(Path.to_string p) ~mode:Single
;;

let if_file_exists p ~then_ ~else_ =
of_thunk
{ f =
(fun mode ->
let open Memo.O in
Build_system.file_exists p
>>= function
| true -> run then_ mode
| false -> run else_ mode)
let open Memo.O in
Build_system.file_exists p
>>= function
| true -> run then_ mode
| false -> run else_ mode)
}
;;

let file_exists p = if_file_exists p ~then_:(return true) ~else_:(return false)

let paths_existing paths =
all_unit
(List.map paths ~f:(fun file ->
if_file_exists file ~then_:(path file) ~else_:(return ())))
;;

let fail x =
let+ () = return () in
x.fail ()
;;

(* CR-someday amokhov: The set of targets is accumulated using information from
multiple sources by calling [Targets.combine], which performs set union and
hence duplicate declarations of the very same target can go unnoticed. I
think such redeclarations are not erroneous but are merely redundant; perhaps
we should detect and disallow them. *)
module With_targets = struct
type nonrec 'a t =
{ build : 'a t
; targets : Targets.t
}

let map_build t ~f = { t with build = f t.build }
let return x = { build = return x; targets = Targets.empty }

let add t ~file_targets =
{ build = t.build
; targets =
Targets.combine
t.targets
(Targets.Files.create (Path.Build.Set.of_list file_targets))
}
;;

let add_directories t ~directory_targets =
{ build = t.build
; targets =
Targets.combine
t.targets
(Targets.create
~dirs:(Path.Build.Set.of_list directory_targets)
~files:Path.Build.Set.empty)
}
;;

let map { build; targets } ~f = { build = map build ~f; targets }

let map2 x y ~f =
{ build = map2 x.build y.build ~f; targets = Targets.combine x.targets y.targets }
;;

let both x y =
{ build = both x.build y.build; targets = Targets.combine x.targets y.targets }
;;

let seq x y =
{ build = x.build >>> y.build; targets = Targets.combine x.targets y.targets }
;;

module O = struct
let ( >>> ) = seq
let ( >>| ) t f = map t ~f
let ( and+ ) = both
let ( let+ ) a f = map ~f a
end

open O

let all xs =
match xs with
| [] -> return []
| xs ->
let build, targets =
List.fold_left xs ~init:([], Targets.empty) ~f:(fun (builds, targets) x ->
x.build :: builds, Targets.combine x.targets targets)
in
{ build = all (List.rev build); targets }
;;

let write_file_dyn ?(perm = Action.File_perm.Normal) fn s =
add
~file_targets:[ fn ]
(let+ s = s in
Action.Full.make (Action.Write_file (fn, perm, s)))
;;

let memoize name t = { build = memoize name t.build; targets = t.targets }
end

let with_targets build ~targets : _ With_targets.t = { build; targets }

let with_file_targets build ~file_targets : _ With_targets.t =
{ build; targets = Targets.Files.create (Path.Build.Set.of_list file_targets) }
;;

let with_no_targets build : _ With_targets.t = { build; targets = Targets.empty }

let write_file ?(perm = Action.File_perm.Normal) fn s =
with_file_targets
~file_targets:[ fn ]
(return (Action.Full.make (Action.Write_file (fn, perm, s))))
;;

let write_file_dyn ?(perm = Action.File_perm.Normal) fn s =
with_file_targets
~file_targets:[ fn ]
(let+ s = s in
Action.Full.make (Action.Write_file (fn, perm, s)))
;;

let with_stdout_to ?(perm = Action.File_perm.Normal) fn t =
with_targets
~targets:(Targets.File.create fn)
(let+ (act : Action.Full.t) = t in
Action.Full.map act ~f:(Action.with_stdout_to ~perm fn))
;;

let copy ~src ~dst =
with_file_targets
~file_targets:[ dst ]
(path src >>> return (Action.Full.make (Action.Copy (src, dst))))
;;

let symlink ~src ~dst =
with_file_targets
~file_targets:[ dst ]
(path src >>> return (Action.Full.make (Action.Symlink (src, dst))))
;;

let symlink_dir ~src ~dst =
with_targets
~targets:
(Targets.create ~files:Path.Build.Set.empty ~dirs:(Path.Build.Set.singleton dst))
(path src >>> return (Action.Full.make (Action.Symlink (src, dst))))
;;

let create_file ?(perm = Action.File_perm.Normal) fn =
with_file_targets
~file_targets:[ fn ]
(return (Action.Full.make (Action.Redirect_out (Stdout, fn, perm, Action.empty))))
;;

let progn ts =
let open With_targets.O in
With_targets.all ts >>| Action.Full.reduce
;;

let dyn_of_memo_deps t = dyn_deps (dyn_of_memo t)

module Alias_status = struct
module T = struct
type t =
| Defined
| Not_defined

let empty : t = Not_defined

let combine : t -> t -> t =
fun x y ->
match x, y with
| _, Defined | Defined, _ -> Defined
| Not_defined, Not_defined -> Not_defined
;;
end

include T
include Monoid.Make (T)
end

module Alias_build_info = struct
type t =
{ alias_status : Alias_status.t
; allowed_build_only_subdirs : Filename.Set.t
}

let of_dir_set ~status dirs =
let allowed_build_only_subdirs =
match Dir_set.toplevel_subdirs dirs with
| Infinite -> Filename.Set.empty
| Finite sub_dirs -> sub_dirs
in
{ alias_status = status; allowed_build_only_subdirs }
;;
end

let dep_on_alias_build_info_if_exists alias =
of_thunk
{ f =
(fun mode ->
let open Memo.O in
Load_rules.load_dir ~dir:(Path.build (Alias.dir alias))
>>= function
| Source _ | External _ ->
Code_error.raise "Alias in a non-build dir" [ "alias", Alias.to_dyn alias ]
| Build { aliases; allowed_subdirs; rules_here = _ } ->
(match Alias.Name.Map.find aliases (Alias.name alias) with
| None ->
Memo.return
( Alias_build_info.of_dir_set ~status:Not_defined allowed_subdirs
, Dep.Map.empty )
| Some _ ->
let deps = Dep.Set.singleton (Dep.alias alias) in
let+ deps = register_action_deps mode deps in
Alias_build_info.of_dir_set ~status:Defined allowed_subdirs, deps)
| Build_under_directory_target _ ->
Memo.return
( Alias_build_info.of_dir_set ~status:Not_defined Dir_set.empty
, Dep.Map.empty ))
}
;;

module Alias_rec (Traverse : sig
val traverse
: Path.Build.t
-> f:(path:Path.Build.t -> Alias_build_info.t t)
-> Alias_status.t t
end) =
struct
open Traverse

let dep_on_alias_rec name dir =
let f ~path = dep_on_alias_build_info_if_exists (Alias.make ~dir:path name) in
traverse dir ~f
;;
end
Loading

0 comments on commit d93a5d2

Please sign in to comment.