From 68107c40ecf3f29357b0ef37319a33e947e12800 Mon Sep 17 00:00:00 2001 From: Arseniy Alekseyev Date: Mon, 1 Apr 2019 14:29:04 +0100 Subject: [PATCH 01/11] Introduce Scheme Signed-off-by: Arseniy Alekseyev --- src/dir_set.ml | 242 +++++++++++++++++++++++++++++++++++++ src/dir_set.mli | 52 ++++++++ src/memo/memo.ml | 7 ++ src/memo/memo.mli | 3 + src/rules.ml | 41 +++++++ src/rules.mli | 21 ++++ src/scheme.ml | 208 +++++++++++++++++++++++++++++++ src/scheme.mli | 24 ++++ src/scheme_intf.ml | 38 ++++++ src/stdune/path.ml | 7 ++ src/stdune/path.mli | 1 + test/unit-tests/dune | 16 +++ test/unit-tests/scheme.mlt | 146 ++++++++++++++++++++++ 13 files changed, 806 insertions(+) create mode 100644 src/dir_set.ml create mode 100644 src/dir_set.mli create mode 100644 src/rules.ml create mode 100644 src/rules.mli create mode 100644 src/scheme.ml create mode 100644 src/scheme.mli create mode 100644 src/scheme_intf.ml create mode 100644 test/unit-tests/scheme.mlt diff --git a/src/dir_set.ml b/src/dir_set.ml new file mode 100644 index 00000000000..fb166bd78b6 --- /dev/null +++ b/src/dir_set.ml @@ -0,0 +1,242 @@ +open! Stdune + +module T : sig + + type t = + | Empty + | Universal + | Nontrivial of nontrivial + and + nontrivial = private { + here : bool; + children : children; + } + and + children = private { + default : bool; + exceptions : t String.Map.t; + } + + val create : here:bool -> children:children -> t + val create_children : default:bool -> exceptions:t String.Map.t -> children + + val is_empty : t -> bool + val is_universal : t -> bool + +end = struct + + type t = + | Empty + | Universal + | Nontrivial of nontrivial + and + nontrivial = { + here : bool; + children : children; + } + and + children = { + default : bool; + exceptions : t String.Map.t; + } + + let is_universal ~here ~children = + String.Map.is_empty children.exceptions && here && children.default + + let is_empty ~here ~children = + String.Map.is_empty children.exceptions + && not here && not children.default + + let create ~here ~children = + if is_empty ~here ~children then Empty + else + if is_universal ~here ~children then Universal + else + Nontrivial { here; children } + + let is_empty = function + | Empty -> true + | _ -> false + + let is_universal = function + | Universal -> true + | _ -> false + + let is_trivial ~value t = match value with + | false -> is_empty t + | true -> is_universal t + + let create_children ~default ~exceptions = + { default; + exceptions = + String.Map.filter exceptions + ~f:(fun v -> not (is_trivial ~value:default v)); + } + +end + +include T + +let empty = Empty +let universal = Universal + +let empty_children = + create_children ~default:false ~exceptions:String.Map.empty +let universal_children = + create_children ~default:true ~exceptions:String.Map.empty + +let trivial v = match v with + | false -> empty + | true -> universal + +module Children = struct + + type set = T.t + + type t = T.children = private { + default : bool; + exceptions : T.t String.Map.t; + } + + let exceptions t = t.exceptions + let default t = t.default + + let create = create_children + +end + +let rec union x y = + match x, y with + | Empty, _ -> y + | _, Empty -> x + | Universal, _ | _, Universal -> universal + | Nontrivial x, Nontrivial y -> + create + ~here:(x.here || y.here) + ~children:(union_children x.children y.children) +and + union_children x y = + create_children + ~default:(x.default || y.default) + ~exceptions:( + String.Map.merge + x.exceptions + y.exceptions + ~f:(fun _key vx vy -> + let vx = Option.value vx ~default:(trivial x.default) in + let vy = Option.value vy ~default:(trivial y.default) in + Some (union vx vy))) + +let rec intersect x y = + match x, y with + | Universal, _ -> y + | _, Universal -> x + | Empty, _ | _, Empty -> empty + | Nontrivial x, Nontrivial y -> + create + ~here:(x.here && y.here) + ~children:(intersect_children x.children y.children) +and + intersect_children x y = + create_children + ~default:(x.default && y.default) + ~exceptions:( + String.Map.merge + x.exceptions + y.exceptions + ~f:(fun _key vx vy -> + let vx = Option.value vx ~default:(trivial x.default) in + let vy = Option.value vy ~default:(trivial y.default) in + Some (intersect vx vy))) + +let rec negate x = + match x with + | Universal -> empty + | Empty -> universal + | Nontrivial { here; children } -> + create ~here:(not here) + ~children:( + Children.create + ~default:(not children.default) + ~exceptions:(String.Map.map children.exceptions ~f:(negate))) + +let here = function + | Empty -> false + | Universal -> true + | Nontrivial t -> t.here + +let children = function + | Empty -> empty_children + | Universal -> universal_children + | Nontrivial t -> t.children + +let rec mem t dir = match dir with + | [] -> here t + | child :: rest -> + let children = children t in + match String.Map.find children.exceptions child with + | None -> children.default + | Some t -> + mem t rest + +let mem t dir = mem t (Path.Build.explode dir) + +let descend t child = + let children = children t in + match String.Map.find children.exceptions child with + | None -> trivial children.default + | Some t -> t + +let union_all = List.fold_left ~init:empty ~f:union + +let of_subtree_gen subtree = + let rec loop = function + | [] -> subtree + | component :: rest -> + create ~here:false + ~children:( + Children.create ~default:false + ~exceptions:(String.Map.singleton component (loop rest))) + in + fun path -> loop (Path.Build.explode path) + +let just_the_root = + create + ~here:true + ~children:(Children.create ~default:false ~exceptions:String.Map.empty) + +let of_subtrees paths = + List.map paths ~f:(of_subtree_gen universal) + |> union_all + +let of_individual_dirs paths = + List.map paths ~f:(of_subtree_gen just_the_root) + |> union_all + +type element = + | One_dir of Path.Build.t + | Subtree of Path.Build.t + +let of_list list = + List.map list ~f:(function + | One_dir dir -> of_subtree_gen just_the_root dir + | Subtree dir -> of_subtree_gen universal dir) + |> union_all + +let is_subset x ~of_ = + is_empty (intersect x (negate of_)) + +let rec to_sexp t = match t with + | Empty -> Sexp.Atom "Empty" + | Universal -> Sexp.Atom "Universal" + | Nontrivial t -> + Sexp.List ( + ( + (match t.here with | true -> [ ".", Sexp.Atom "true" ] | false -> []) @ + (String.Map.to_list t.children.exceptions + |> List.map ~f:(fun (s, t) -> + s, to_sexp t)) @ + (match t.children.default with + | false -> [] + | true -> [("*", Sexp.Atom "Universal")])) + |> List.map ~f:(fun (k, v) -> Sexp.List [Sexp.Atom k; v])) diff --git a/src/dir_set.mli b/src/dir_set.mli new file mode 100644 index 00000000000..5351435b4df --- /dev/null +++ b/src/dir_set.mli @@ -0,0 +1,52 @@ +open! Stdune + +(** Represents a (potentially infinite) set of directories. Not any set can be specified, + only ones that can be efficiently inspected. *) + +type children + +type t + +(* Total mapping from the child basename to a [t]. + Only a finite number of bindings can be non-trivial. + + The "trivial" ones will be either all [trivial true] or all [trivial false]. *) +module Children : sig + type set = t + type t = children + + val default : t -> bool + val exceptions : t -> set String.Map.t + + val create : default:bool -> exceptions:set String.Map.t -> t +end + +val here : t -> bool +val children : t -> Children.t + +val empty : t +val universal : t + +val is_empty : t -> bool +val is_universal : t -> bool + +val mem : t -> Path.Build.t -> bool + +val descend : t -> string -> t + +val of_subtrees : Path.Build.t list -> t +val of_individual_dirs : Path.Build.t list -> t + +type element = + | One_dir of Path.Build.t + | Subtree of Path.Build.t + +val of_list : element list -> t + +val is_subset : t -> of_:t -> bool + +val union : t -> t -> t +val intersect : t -> t -> t +val negate : t -> t + +val to_sexp : t -> Sexp.t diff --git a/src/memo/memo.ml b/src/memo/memo.ml index 46bffc266a0..df2b97fd78f 100644 --- a/src/memo/memo.ml +++ b/src/memo/memo.ml @@ -724,6 +724,13 @@ module Lazy = struct let of_val x = fun () -> x let create f = lazy_ f let force f = f () + + let map2 x y ~f = + create (fun () -> f (x ()) (y ())) + + let bind x ~f = + create (fun () -> force (f (force x))) + end module With_implicit_output = struct diff --git a/src/memo/memo.mli b/src/memo/memo.mli index b57c2bbe0a1..cb3fea31ede 100644 --- a/src/memo/memo.mli +++ b/src/memo/memo.mli @@ -167,6 +167,9 @@ val function_info : string -> Function_info.t module Lazy : sig type 'a t + val map2 : 'a t -> 'b t -> f:('a -> 'b -> 'c) -> 'c t + val bind : 'a t -> f:('a -> 'b t) -> 'b t + val create : (unit -> 'a) -> 'a t val of_val : 'a -> 'a t val force : 'a t -> 'a diff --git a/src/rules.ml b/src/rules.ml new file mode 100644 index 00000000000..e43d1a9e1de --- /dev/null +++ b/src/rules.ml @@ -0,0 +1,41 @@ +open! Stdune + +type rule = unit -> unit + +module T = struct + type t = rule Path.Build.Map.t + + let empty = Path.Build.Map.empty + + let union_map a b ~f = + Path.Build.Map.union a b ~f:(fun _key a b -> Some (f a b)) + + let union = + union_map ~f:(fun rule1 rule2 -> fun () -> rule1 (); rule2 ()) + + let name = "Rules" +end + +include T + +let file_rule ~rule:(dst, rule) = + let dst = Path.as_in_build_dir_exn dst in + Path.Build.Map.singleton (Path.Build.parent_exn dst) rule + +let dir_rule (dir, rule) = + let dir = Path.as_in_build_dir_exn dir in + Path.Build.Map.singleton dir rule + +let implicit_output = Memo.Implicit_output.add(module T) + +let file_rule ~rule = + Memo.Implicit_output.produce implicit_output (file_rule ~rule) + +let dir_rule arg = + Memo.Implicit_output.produce implicit_output (dir_rule arg) + +let collect f = + let result, out = Memo.Implicit_output.collect_sync implicit_output f in + result, Option.value out ~default:T.empty + +let to_map x = x diff --git a/src/rules.mli b/src/rules.mli new file mode 100644 index 00000000000..6aebc9fcef2 --- /dev/null +++ b/src/rules.mli @@ -0,0 +1,21 @@ +(** [Rules] represents a collection of rules across a known set of directories. *) + +open! Stdune + +(** [rule] is a function that produces some build system rules + such as ([Build_system.add_rule]) in a known directory. *) +type rule = unit -> unit + +type t = private rule Path.Build.Map.t + +val to_map : t -> rule Path.Build.Map.t + +(* [Path] must be in build directory *) +val file_rule : rule:(Path.t * rule) -> unit + +(* [Path] must be in build directory *) +val dir_rule : (Path.t * rule) -> unit + +val union : t -> t -> t + +val collect : (unit -> 'a) -> ('a * t) diff --git a/src/scheme.ml b/src/scheme.ml new file mode 100644 index 00000000000..485c0fc5e57 --- /dev/null +++ b/src/scheme.ml @@ -0,0 +1,208 @@ +open! Stdune + +open Scheme_intf + +module Path = Path.Build + +module Gen' = struct + include Gen + module Evaluated = struct + type 'rules t = { + by_child : 'rules t Memo.Lazy.t String.Map.t; + rules_here : 'rules Memo.Lazy.t; + } + end +end +open Gen' + +module Make(Rules : sig + type t + val empty : t + val union : t -> t -> t + end) = struct + + type 'rules t_gen = 'rules Gen.t = + | Empty + | Union of 'rules t_gen * 'rules t_gen + | Approximation of Dir_set.t * 'rules t_gen + | Finite of 'rules Path.Map.t + | Thunk of (unit -> 'rules t_gen) + + type t = Rules.t Gen.t + + module Evaluated = struct + type 'rules t_gen = 'rules Evaluated.t = { + by_child : 'rules t_gen Memo.Lazy.t String.Map.t; + rules_here : 'rules Memo.Lazy.t; + } + type t = Rules.t t_gen + + let empty = + { by_child = String.Map.empty; + rules_here = Memo.Lazy.of_val Rules.empty; + } + + let descend t dir = + match String.Map.find t.by_child dir with + | None -> empty + | Some res -> Memo.Lazy.force res + + let rec union ~union_rules x y = + { + by_child = + String.Map.union x.by_child y.by_child + ~f:(fun _key data1 data2 -> Some ( + Memo.Lazy.map2 data1 data2 + ~f:(fun x y -> union ~union_rules x y))); + rules_here = + Memo.Lazy.map2 x.rules_here y.rules_here ~f:union_rules + } + + let union = union ~union_rules:Rules.union + + let rec restrict (dirs : Dir_set.t) t : t = + { + rules_here = + (if Dir_set.here dirs then + Memo.Lazy.bind t ~f:(fun t -> t.rules_here) + else + Memo.Lazy.of_val Rules.empty); + by_child = + let dirs_children = Dir_set.children dirs in + (match Dir_set.Children.default dirs_children with + | true -> + (* This is forcing the lazy potentially too early if the directory + the user is interested in is not actually in the set. We're not + fully committed to supporting this case though, anyway. *) + String.Map.mapi (Memo.Lazy.force t).by_child + ~f:(fun dir v -> + Memo.lazy_ (fun () -> + restrict + (Dir_set.descend dirs dir) + v)) + | false -> + String.Map.mapi (Dir_set.Children.exceptions dirs_children) + ~f:(fun dir v -> + Memo.lazy_ (fun () -> + restrict + v + (Memo.lazy_ (fun () -> + descend (Memo.Lazy.force t) dir))))); + } + + let singleton path (rules : Rules.t) = + let rec go = function + | [] -> + { by_child = String.Map.empty; rules_here = Memo.Lazy.of_val rules; } + | x :: xs -> + { + by_child = String.Map.singleton x (Memo.Lazy.of_val (go xs)); + rules_here = Memo.Lazy.of_val Rules.empty; + } + in + go (Path.explode path) + + let finite m = + Path.Map.to_list m + |> List.map ~f:(fun (path, rules) -> + singleton path rules) + |> List.fold_left ~init:empty ~f:union + + end + + let rec evaluate ~env = function + | Empty -> Evaluated.empty + | Union (x, y) -> Evaluated.union (evaluate ~env x) (evaluate ~env y) + | Approximation (paths, rules) -> + if + not (Dir_set.is_subset paths ~of_:env) + && not (Dir_set.is_subset (Dir_set.negate paths) ~of_:env) + then + raise (Exn.code_error + "inner [Approximate] specifies a set such that neither it, \ + nor its negation, are a subset of directories specified by \ + the outer [Approximate]." + [ + "inner", (Dir_set.to_sexp paths); + "outer", (Dir_set.to_sexp env); + ]) + else + let paths = Dir_set.intersect paths env in + Evaluated.restrict paths + (Memo.lazy_ (fun () -> evaluate ~env:paths rules)) + | Finite rules -> Evaluated.finite rules + | Thunk f -> evaluate ~env (f ()) + + let all l = List.fold_left ~init:Empty ~f:(fun x y -> Union (x, y)) l + + module For_tests = struct + (* [collect_rules_simple] is oversimplified in two ways: + - it does not share the work of scheme flattening, so repeated lookups do + repeated work + - it does not check that approximations are correct + + If approximations are not correct, it will honor the approximation. + So approximations act like views that prevent the rules from being seen + rather than from being declared in the first place. + *) + let collect_rules_simple = + let rec go (t : t) ~dir = + match t with + | Empty -> Rules.empty + | Union (a, b) -> Rules.union(go a ~dir) (go b ~dir) + | Approximation (dirs, t) -> + (match Dir_set.mem dirs dir with + | true -> go t ~dir + | false -> Rules.empty) + | Finite rules -> + (match Path.Map.find rules dir with + | None -> Rules.empty + | Some rule -> rule) + | Thunk f -> + go (f ()) ~dir + in + go + + end + + let get_rules : Evaluated.t -> dir:Path.t -> Rules.t = + fun t ~dir -> + let dir = Path.explode dir in + let t = List.fold_left dir ~init:t ~f:Evaluated.descend in + Memo.Lazy.force t.rules_here + + let evaluate = evaluate ~env:Dir_set.universal + +end + +module Rules_scheme = Make(struct + type t = unit -> unit + let empty = (fun () -> ()) + let union f g () = f (); g () + end) + +include Rules_scheme + +module Gen = struct + module For_tests = struct + + let instrument ~print = + let print path suffix = + print (String.concat (List.rev path @ [suffix]) ~sep:":") + in + let rec go ~path t = match t with + | Gen.Empty -> Gen.Empty + | Union (t1, t2) -> + Union (go ~path:("l"::path) t1, go ~path:("r"::path) t2) + | Approximation (dirs, rules) -> + let path = "t" :: path in + Approximation (dirs, go ~path rules) + | Finite m -> Finite m + | Thunk t -> + Thunk (fun () -> + print path "thunk"; + t ()) + in + go ~path:[] + end +end diff --git a/src/scheme.mli b/src/scheme.mli new file mode 100644 index 00000000000..6b181c51593 --- /dev/null +++ b/src/scheme.mli @@ -0,0 +1,24 @@ +open! Stdune + +(** [Scheme] is a collection of rules for one or multiple directories. *) + +open Scheme_intf + +module Make(Directory_rules : sig + type t + val empty : t + val union : t -> t -> t + end) : S with type dir_rules := Directory_rules.t + +include S with type dir_rules := Rules.rule + +module Gen : sig + module For_tests : sig + (* calls [print] every time any code embedded in the [Scheme] runs, be it + a [Thunk] constructor or an [Approximation] function. + + The argument of [print] identifies which thunk got run (the path to that + thunk within the [Scheme.t] value). *) + val instrument : print:(string -> unit) -> 'a Gen.t -> 'a Gen.t + end +end diff --git a/src/scheme_intf.ml b/src/scheme_intf.ml new file mode 100644 index 00000000000..3cd290fdc54 --- /dev/null +++ b/src/scheme_intf.ml @@ -0,0 +1,38 @@ +open! Stdune + +module Gen = struct + type 'rules t = + | Empty + | Union of 'rules t * 'rules t + | Approximation of Dir_set.t * 'rules t + | Finite of 'rules Path.Build.Map.t + | Thunk of (unit -> 'rules t) +end + +module type S = sig + + type dir_rules + + type 'rules t_gen = 'rules Gen.t = + | Empty + | Union of 'rules t_gen * 'rules t_gen + | Approximation of Dir_set.t * 'rules t_gen + | Finite of 'rules Path.Build.Map.t + | Thunk of (unit -> 'rules t_gen) + + type t = dir_rules t_gen + + module Evaluated : sig + type t + end + + module For_tests : sig + val collect_rules_simple : t -> dir:Path.Build.t -> dir_rules + end + + val evaluate : t -> Evaluated.t + + val get_rules : Evaluated.t -> dir:Path.Build.t -> dir_rules + + val all : t list -> t +end diff --git a/src/stdune/path.ml b/src/stdune/path.ml index d5934ddb94b..6bd303be9da 100644 --- a/src/stdune/path.ml +++ b/src/stdune/path.ml @@ -923,6 +923,13 @@ let split_first_component t = end | _, _ -> None +let as_in_build_dir_exn t = match t with + | External _ | In_source_tree _ -> + Exn.code_error + "[as_in_build_dir_exn] called on something not in build dir" + ["t", to_sexp t] + | In_build_dir p -> p + let explode t = match kind t with | Local p when Local.is_root p -> Some [] diff --git a/src/stdune/path.mli b/src/stdune/path.mli index 34d5ab0528b..500c448e242 100644 --- a/src/stdune/path.mli +++ b/src/stdune/path.mli @@ -187,6 +187,7 @@ val build_dir : t (** [is_in_build_dir t = is_descendant t ~of:build_dir] *) val is_in_build_dir : t -> bool +val as_in_build_dir_exn : t -> Build.t (** [is_in_build_dir t = is_managed t && not (is_in_build_dir t)] *) val is_in_source_tree : t -> bool diff --git a/test/unit-tests/dune b/test/unit-tests/dune index 8d0aac5f5c6..20c11a5e796 100644 --- a/test/unit-tests/dune +++ b/test/unit-tests/dune @@ -193,3 +193,19 @@ (progn (run %{exe:expect_test.exe} %{t}) (diff? %{t} %{t}.corrected))))) + +(alias + (name runtestscheme) + (deps (:t scheme.mlt) + (glob_files %{project_root}/src/.dune.objs/byte/*.cmi) + (glob_files %{project_root}/src/stdune/.stdune.objs/byte/*.cmi) + (glob_files %{project_root}/src/memo/.memo.objs/byte/*.cmi) + (glob_files %{project_root}/src/fiber/.fiber.objs/byte/*.cmi)) + (action (chdir %{project_root} + (progn + (run %{exe:expect_test.exe} %{t}) + (diff? %{t} %{t}.corrected)))) +) +(alias + (name runtest) + (deps (alias runtestscheme))) diff --git a/test/unit-tests/scheme.mlt b/test/unit-tests/scheme.mlt new file mode 100644 index 00000000000..cdcf12fbaa8 --- /dev/null +++ b/test/unit-tests/scheme.mlt @@ -0,0 +1,146 @@ +open Stdune + +let print = Printf.printf "%s\n" + +module Directory_rules = struct + type element = + | File of string + | Thunk of (unit -> t) + and + t = element Appendable_list.t + + let empty = Appendable_list.empty + let union = Appendable_list.(@) + let concat t = List.fold_left t ~init:empty ~f:union + let thunk f = Appendable_list.singleton (Thunk f) + let file f = Appendable_list.singleton (File f) + + let rec force l = + List.concat_map (Appendable_list.to_list l) ~f:(function + | File t -> [t] + | Thunk f -> + force (f ())) +end + +module Scheme = struct + include Dune.Scheme.Gen.For_tests + include Dune.Scheme.Make(Directory_rules) +end + +module Dir_set = Dune.Dir_set + +module Path = struct + include Path.Build + + let of_string str = L.relative root ( + match String.split str ~on:'/' with + | [""] -> [] + | ["."] -> [] + | other -> other) +end + +[%%ignore] + +let record_calls scheme ~f = + let calls = ref [] in + let scheme = + Scheme.instrument ~print:(fun s -> calls := s :: !calls) scheme + in + let res = f scheme in + (Directory_rules.force res, !calls) + +let print_rules scheme ~dir = + let res1, calls1 = + record_calls scheme ~f:(Scheme.For_tests.collect_rules_simple ~dir) + in + let res2, calls2 = + record_calls scheme ~f:(fun scheme -> + Scheme.get_rules (Scheme.evaluate scheme) ~dir) + in + if not ((res1 : string list) = res2) + then + Exn.code_error + "Naive [collect_rules_simple] gives result inconsistent with [Scheme.evaluate]" + [ + "res1", Sexp.List (List.map res1 ~f:(fun s -> Sexp.Atom s)); + "res2", Sexp.List (List.map res2 ~f:(fun s -> Sexp.Atom s)); + ] + else + ( + let print_log log = + let log = match log with | [] -> [""] | x -> x in + List.iter log ~f:(fun s -> print (" " ^ s)) + in + (if not ((calls1 : string list) = calls2) then ( + print "inconsistent laziness behavior:"; + print "naive calls:"; + print_log calls1; + print "[evalulate] calls:"; + print_log calls2;) + else ( + print "calls:"; + print_log calls1 + ) + ); + print "rules:"; + print_log res1) +[%%ignore] + +open Dune.Scheme + +let () = + let scheme = + Dune.Scheme.Thunk (fun () -> Dune.Scheme.Empty) + in + print_rules scheme ~dir:(Path.of_string "foo/bar") + +[%%expect{| +calls: + thunk +rules: + +|}] + +let scheme_all_but_foo_bar = + Dune.Scheme.Approximation ( + Dir_set.negate ( + Dir_set.of_list [Dir_set.Subtree (Path.of_string "foo/bar")]), + Thunk (fun () -> Empty)) + +[%%ignore] + +let () = + print_rules scheme_all_but_foo_bar ~dir:(Path.of_string "unrelated/dir") + +[%%expect{| +calls: + t:thunk +rules: + +|}] + +let () = + print_rules scheme_all_but_foo_bar ~dir:(Path.of_string "foo/bar") + +[%%expect{| +inconsistent laziness behavior: +naive calls: + +[evalulate] calls: + t:thunk +rules: + +|}] + +let () = + print_rules scheme_all_but_foo_bar ~dir:(Path.of_string "foo/bar/baz") + +[%%expect{| +inconsistent laziness behavior: +naive calls: + +[evalulate] calls: + t:thunk +rules: + +|}] From 7938a42057ab0466ba9c0d7693c7210b40b5a22b Mon Sep 17 00:00:00 2001 From: Jeremie Dimino Date: Thu, 2 May 2019 16:52:31 +0100 Subject: [PATCH 02/11] A few changes to Dir_set - add more doc and try to make the API more "progressive", i.e. going from simple to complex concepts - reduce the number of intermediate maps in the various operations - use a more compact representation - rename `intersect` to `inter` to match `Set`'s API Signed-off-by: Jeremie Dimino --- src/dir_set.ml | 331 +++++++++++++++---------------------- src/dir_set.mli | 77 +++++---- src/scheme.ml | 7 +- test/unit-tests/scheme.mlt | 2 +- 4 files changed, 187 insertions(+), 230 deletions(-) diff --git a/src/dir_set.ml b/src/dir_set.ml index fb166bd78b6..85dc9629131 100644 --- a/src/dir_set.ml +++ b/src/dir_set.ml @@ -1,242 +1,181 @@ open! Stdune -module T : sig - - type t = - | Empty - | Universal - | Nontrivial of nontrivial - and - nontrivial = private { - here : bool; - children : children; - } - and - children = private { - default : bool; - exceptions : t String.Map.t; - } - - val create : here:bool -> children:children -> t - val create_children : default:bool -> exceptions:t String.Map.t -> children - - val is_empty : t -> bool - val is_universal : t -> bool - -end = struct - - type t = - | Empty - | Universal - | Nontrivial of nontrivial - and - nontrivial = { - here : bool; - children : children; - } - and - children = { - default : bool; - exceptions : t String.Map.t; - } - - let is_universal ~here ~children = - String.Map.is_empty children.exceptions && here && children.default - - let is_empty ~here ~children = - String.Map.is_empty children.exceptions - && not here && not children.default - - let create ~here ~children = - if is_empty ~here ~children then Empty - else - if is_universal ~here ~children then Universal - else - Nontrivial { here; children } - - let is_empty = function - | Empty -> true - | _ -> false - - let is_universal = function - | Universal -> true - | _ -> false - - let is_trivial ~value t = match value with - | false -> is_empty t - | true -> is_universal t - - let create_children ~default ~exceptions = - { default; - exceptions = - String.Map.filter exceptions - ~f:(fun v -> not (is_trivial ~value:default v)); - } +type t = + | Empty + | Universal + | Nontrivial of nontrivial +and nontrivial = { + default : bool; + here : bool; + exceptions : t String.Map.t; +} -end +let here = function + | Empty -> false + | Universal -> true + | Nontrivial t -> t.here + +let default = function + | Empty -> false + | Universal -> true + | Nontrivial t -> t.default -include T +let exceptions = function + | Empty | Universal -> String.Map.empty + | Nontrivial t -> t.exceptions let empty = Empty let universal = Universal -let empty_children = - create_children ~default:false ~exceptions:String.Map.empty -let universal_children = - create_children ~default:true ~exceptions:String.Map.empty - -let trivial v = match v with - | false -> empty - | true -> universal - -module Children = struct - - type set = T.t +let trivial = function + | false -> Empty + | true -> Universal - type t = T.children = private { - default : bool; - exceptions : T.t String.Map.t; - } +let create ~default ~here ~exceptions = + if String.Map.is_empty exceptions && here = default then + trivial default + else + Nontrivial { here; default; exceptions } - let exceptions t = t.exceptions - let default t = t.default +let is_empty = function + | Empty -> true + | _ -> false - let create = create_children - -end +let is_universal = function + | Universal -> true + | _ -> false + +let merge_exceptions a b ~default ~f = + String.Map.merge a.exceptions b.exceptions ~f:(fun _ x y -> + let x = Option.value x ~default:(trivial a.default) in + let y = Option.value y ~default:(trivial b.default) in + match default, f x y with + | false, Empty | true, Universal -> None + | _, res -> Some res) + +let merge_nontrivial a b ~f_one ~f_set = + let default = f_one a.default b.default in + create + ~here:(f_one a.here b.here) + ~default + ~exceptions:(merge_exceptions a b ~default ~f:f_set) +[@@inline always] let rec union x y = match x, y with - | Empty, _ -> y - | _, Empty -> x - | Universal, _ | _, Universal -> universal + | Empty, v | v, Empty -> v + | Universal, _ | _, Universal -> Universal | Nontrivial x, Nontrivial y -> - create - ~here:(x.here || y.here) - ~children:(union_children x.children y.children) -and - union_children x y = - create_children - ~default:(x.default || y.default) - ~exceptions:( - String.Map.merge - x.exceptions - y.exceptions - ~f:(fun _key vx vy -> - let vx = Option.value vx ~default:(trivial x.default) in - let vy = Option.value vy ~default:(trivial y.default) in - Some (union vx vy))) - -let rec intersect x y = + merge_nontrivial x y ~f_one:(||) ~f_set:union + +let rec inter x y = match x, y with - | Universal, _ -> y - | _, Universal -> x - | Empty, _ | _, Empty -> empty + | Universal, v | v, Universal -> v + | Empty, _ | _, Empty -> Empty | Nontrivial x, Nontrivial y -> - create - ~here:(x.here && y.here) - ~children:(intersect_children x.children y.children) -and - intersect_children x y = - create_children - ~default:(x.default && y.default) - ~exceptions:( - String.Map.merge - x.exceptions - y.exceptions - ~f:(fun _key vx vy -> - let vx = Option.value vx ~default:(trivial x.default) in - let vy = Option.value vy ~default:(trivial y.default) in - Some (intersect vx vy))) + merge_nontrivial x y ~f_one:(&&) ~f_set:inter let rec negate x = match x with - | Universal -> empty - | Empty -> universal - | Nontrivial { here; children } -> - create ~here:(not here) - ~children:( - Children.create - ~default:(not children.default) - ~exceptions:(String.Map.map children.exceptions ~f:(negate))) - -let here = function + | Universal -> Empty + | Empty -> Universal + | Nontrivial { here; default; exceptions } -> + Nontrivial { here = not here + ; default = not default + ; exceptions = String.Map.map exceptions ~f:negate + } + +let rec diff x y = + match x with + | Empty -> Empty + | Universal -> negate y + | Nontrivial nx -> + match y with + | Empty -> x + | Universal -> Empty + | Nontrivial ny -> + merge_nontrivial nx ny + ~f_one:(fun a b -> a && not b) + ~f_set:diff + +let rec mem t dir = + match t with | Empty -> false | Universal -> true - | Nontrivial t -> t.here - -let children = function - | Empty -> empty_children - | Universal -> universal_children - | Nontrivial t -> t.children - -let rec mem t dir = match dir with - | [] -> here t - | child :: rest -> - let children = children t in - match String.Map.find children.exceptions child with - | None -> children.default - | Some t -> - mem t rest + | Nontrivial { here; default; exceptions } -> + match dir with + | [] -> here + | child :: rest -> + match String.Map.find exceptions child with + | None -> default + | Some t -> mem t rest let mem t dir = mem t (Path.Build.explode dir) let descend t child = - let children = children t in - match String.Map.find children.exceptions child with - | None -> trivial children.default - | Some t -> t + match t with + | Empty -> Empty + | Universal -> Universal + | Nontrivial { here = _; default; exceptions } -> + match String.Map.find exceptions child with + | None -> trivial default + | Some t -> t let union_all = List.fold_left ~init:empty ~f:union +let inter_all = List.fold_left ~init:empty ~f:inter -let of_subtree_gen subtree = - let rec loop = function +let of_subtree_gen = + let rec loop subtree = function | [] -> subtree | component :: rest -> - create ~here:false - ~children:( - Children.create ~default:false - ~exceptions:(String.Map.singleton component (loop rest))) + Nontrivial + { here = false + ; default = false + ; exceptions = String.Map.singleton component (loop subtree rest) + } in - fun path -> loop (Path.Build.explode path) + fun subtree path -> loop subtree (Path.Build.explode path) let just_the_root = - create - ~here:true - ~children:(Children.create ~default:false ~exceptions:String.Map.empty) - -let of_subtrees paths = - List.map paths ~f:(of_subtree_gen universal) - |> union_all - -let of_individual_dirs paths = - List.map paths ~f:(of_subtree_gen just_the_root) - |> union_all - -type element = - | One_dir of Path.Build.t - | Subtree of Path.Build.t - -let of_list list = - List.map list ~f:(function - | One_dir dir -> of_subtree_gen just_the_root dir - | Subtree dir -> of_subtree_gen universal dir) - |> union_all + Nontrivial + { here = true + ; default = false + ; exceptions = String.Map.empty + } -let is_subset x ~of_ = - is_empty (intersect x (negate of_)) +let subtree p = of_subtree_gen universal p +let singleton p = of_subtree_gen just_the_root p + +let is_subset = + let not_subset () = raise_notrace Exit in + let rec loop x y = + match x, y with + | _, Universal | Empty, _ -> Empty + | Universal, _ | _, Empty -> not_subset () + | Nontrivial x, Nontrivial y -> + if (x.here && not y.here ) || + (x.default && not y.default) then + not_subset (); + ignore + (merge_exceptions x y ~default:false ~f:loop : t String.Map.t); + Empty + in + fun x ~of_ -> + match loop x of_ with + | (_ : t) -> true + | exception Exit -> false let rec to_sexp t = match t with | Empty -> Sexp.Atom "Empty" | Universal -> Sexp.Atom "Universal" - | Nontrivial t -> + | Nontrivial { here; default; exceptions } -> Sexp.List ( ( - (match t.here with | true -> [ ".", Sexp.Atom "true" ] | false -> []) @ - (String.Map.to_list t.children.exceptions + (match here with | true -> [ ".", Sexp.Atom "true" ] | false -> []) @ + (String.Map.to_list exceptions |> List.map ~f:(fun (s, t) -> s, to_sexp t)) @ - (match t.children.default with + (match default with | false -> [] | true -> [("*", Sexp.Atom "Universal")])) |> List.map ~f:(fun (k, v) -> Sexp.List [Sexp.Atom k; v])) diff --git a/src/dir_set.mli b/src/dir_set.mli index 5351435b4df..784190993f7 100644 --- a/src/dir_set.mli +++ b/src/dir_set.mli @@ -1,52 +1,71 @@ -open! Stdune - -(** Represents a (potentially infinite) set of directories. Not any set can be specified, - only ones that can be efficiently inspected. *) +(** Potentially infinite sets of directories *) -type children +open! Stdune +(** Type of potentially infinite sets of directories. Not all sets can + be represented, only ones that can be efficiently inspected. *) type t -(* Total mapping from the child basename to a [t]. - Only a finite number of bindings can be non-trivial. - - The "trivial" ones will be either all [trivial true] or all [trivial false]. *) -module Children : sig - type set = t - type t = children - - val default : t -> bool - val exceptions : t -> set String.Map.t - - val create : default:bool -> exceptions:set String.Map.t -> t -end +(** [mem t p] is [true] if and only if [p] is in [t] *) +val mem : t -> Path.Build.t -> bool +(** [here t] is the same as [mem t Path.Build.root] but more + efficient. *) val here : t -> bool -val children : t -> Children.t +(** The empty set *) val empty : t + +(** The set of all possible directories *) val universal : t +(** [trivial b] is such that for all path [p]: + + {[ + mem (trivial b) p = b + ]} + + i.e. [trivial false] is [empty] and [trivial true] is [universal]. +*) +val trivial : bool -> t + val is_empty : t -> bool val is_universal : t -> bool -val mem : t -> Path.Build.t -> bool - +(** [descend t comp] is the set [t'] such that for all path [p], [p] + is in [t'] iff [comp/p] is in [t]. [comp] must be a path component, + i.e. without directory separator characters. *) val descend : t -> string -> t -val of_subtrees : Path.Build.t list -> t -val of_individual_dirs : Path.Build.t list -> t +(** [exceptions t] is the set of all bindings of the form [(comp, + t']] such that: -type element = - | One_dir of Path.Build.t - | Subtree of Path.Build.t + - [t' = descend t comp] + - [t' <> trivial (default t)] -val of_list : element list -> t + Sets of directories for which [exceptions t] is not finite cannot be + represented by this module. +*) +val exceptions : t -> t String.Map.t -val is_subset : t -> of_:t -> bool +(** Default membership value for paths that are neither empty nor part + of the exceptions. I.e. for all non-empty path [p] whose first + component is not in [exceptions t], [mem t p = default t]. *) +val default : t -> bool + +(** [singleton p] is the set containing only [p] *) +val singleton : Path.Build.t -> t +(** [subtree p] is the set of all directories that are descendant of + [p]. *) +val subtree : Path.Build.t -> t + +val is_subset : t -> of_:t -> bool val union : t -> t -> t -val intersect : t -> t -> t +val union_all : t list -> t +val inter : t -> t -> t +val inter_all : t list -> t +val diff : t -> t -> t val negate : t -> t val to_sexp : t -> Sexp.t diff --git a/src/scheme.ml b/src/scheme.ml index 485c0fc5e57..cb887ffab10 100644 --- a/src/scheme.ml +++ b/src/scheme.ml @@ -68,8 +68,7 @@ module Make(Rules : sig else Memo.Lazy.of_val Rules.empty); by_child = - let dirs_children = Dir_set.children dirs in - (match Dir_set.Children.default dirs_children with + (match Dir_set.default dirs with | true -> (* This is forcing the lazy potentially too early if the directory the user is interested in is not actually in the set. We're not @@ -81,7 +80,7 @@ module Make(Rules : sig (Dir_set.descend dirs dir) v)) | false -> - String.Map.mapi (Dir_set.Children.exceptions dirs_children) + String.Map.mapi (Dir_set.exceptions dirs) ~f:(fun dir v -> Memo.lazy_ (fun () -> restrict @@ -127,7 +126,7 @@ module Make(Rules : sig "outer", (Dir_set.to_sexp env); ]) else - let paths = Dir_set.intersect paths env in + let paths = Dir_set.inter paths env in Evaluated.restrict paths (Memo.lazy_ (fun () -> evaluate ~env:paths rules)) | Finite rules -> Evaluated.finite rules diff --git a/test/unit-tests/scheme.mlt b/test/unit-tests/scheme.mlt index cdcf12fbaa8..332fd9c27b2 100644 --- a/test/unit-tests/scheme.mlt +++ b/test/unit-tests/scheme.mlt @@ -104,7 +104,7 @@ rules: let scheme_all_but_foo_bar = Dune.Scheme.Approximation ( Dir_set.negate ( - Dir_set.of_list [Dir_set.Subtree (Path.of_string "foo/bar")]), + Dir_set.subtree (Path.of_string "foo/bar")), Thunk (fun () -> Empty)) [%%ignore] From 6a529ed78b12a7e8518fb5857f880bdd135c200a Mon Sep 17 00:00:00 2001 From: Arseniy Alekseyev Date: Mon, 6 May 2019 15:03:13 +0100 Subject: [PATCH 03/11] nontrivial here is a bit non-obvious Signed-off-by: Arseniy Alekseyev --- src/dir_set.ml | 9 ++++----- 1 file changed, 4 insertions(+), 5 deletions(-) diff --git a/src/dir_set.ml b/src/dir_set.ml index 85dc9629131..3e5a1d58d6d 100644 --- a/src/dir_set.ml +++ b/src/dir_set.ml @@ -128,11 +128,10 @@ let of_subtree_gen = let rec loop subtree = function | [] -> subtree | component :: rest -> - Nontrivial - { here = false - ; default = false - ; exceptions = String.Map.singleton component (loop subtree rest) - } + create + ~here:false + ~default:false + ~exceptions:(String.Map.singleton component (loop subtree rest)) in fun subtree path -> loop subtree (Path.Build.explode path) From 4c1d2742822d093b64134f5252d46de864e7ee23 Mon Sep 17 00:00:00 2001 From: Jeremie Dimino Date: Mon, 6 May 2019 17:27:02 +0100 Subject: [PATCH 04/11] Simplify a bit the module buisiness + move the test code to the testsuite Signed-off-by: Jeremie Dimino --- src/scheme.ml | 78 ++++++-------------------------------- src/scheme.mli | 25 ++++++------ src/scheme_intf.ml | 25 ++---------- test/unit-tests/scheme.mlt | 59 ++++++++++++++++++++++++++-- 4 files changed, 82 insertions(+), 105 deletions(-) diff --git a/src/scheme.ml b/src/scheme.ml index cb887ffab10..d6a46522fdc 100644 --- a/src/scheme.ml +++ b/src/scheme.ml @@ -1,11 +1,15 @@ open! Stdune -open Scheme_intf - module Path = Path.Build -module Gen' = struct - include Gen +module Gen = struct + type 'rules t = + | Empty + | Union of 'rules t * 'rules t + | Approximation of Dir_set.t * 'rules t + | Finite of 'rules Path.Map.t + | Thunk of (unit -> 'rules t) + module Evaluated = struct type 'rules t = { by_child : 'rules t Memo.Lazy.t String.Map.t; @@ -13,21 +17,15 @@ module Gen' = struct } end end -open Gen' +open Gen + +module type S = Scheme_intf.S with module Gen := Gen module Make(Rules : sig type t val empty : t val union : t -> t -> t end) = struct - - type 'rules t_gen = 'rules Gen.t = - | Empty - | Union of 'rules t_gen * 'rules t_gen - | Approximation of Dir_set.t * 'rules t_gen - | Finite of 'rules Path.Map.t - | Thunk of (unit -> 'rules t_gen) - type t = Rules.t Gen.t module Evaluated = struct @@ -134,36 +132,6 @@ module Make(Rules : sig let all l = List.fold_left ~init:Empty ~f:(fun x y -> Union (x, y)) l - module For_tests = struct - (* [collect_rules_simple] is oversimplified in two ways: - - it does not share the work of scheme flattening, so repeated lookups do - repeated work - - it does not check that approximations are correct - - If approximations are not correct, it will honor the approximation. - So approximations act like views that prevent the rules from being seen - rather than from being declared in the first place. - *) - let collect_rules_simple = - let rec go (t : t) ~dir = - match t with - | Empty -> Rules.empty - | Union (a, b) -> Rules.union(go a ~dir) (go b ~dir) - | Approximation (dirs, t) -> - (match Dir_set.mem dirs dir with - | true -> go t ~dir - | false -> Rules.empty) - | Finite rules -> - (match Path.Map.find rules dir with - | None -> Rules.empty - | Some rule -> rule) - | Thunk f -> - go (f ()) ~dir - in - go - - end - let get_rules : Evaluated.t -> dir:Path.t -> Rules.t = fun t ~dir -> let dir = Path.explode dir in @@ -181,27 +149,3 @@ module Rules_scheme = Make(struct end) include Rules_scheme - -module Gen = struct - module For_tests = struct - - let instrument ~print = - let print path suffix = - print (String.concat (List.rev path @ [suffix]) ~sep:":") - in - let rec go ~path t = match t with - | Gen.Empty -> Gen.Empty - | Union (t1, t2) -> - Union (go ~path:("l"::path) t1, go ~path:("r"::path) t2) - | Approximation (dirs, rules) -> - let path = "t" :: path in - Approximation (dirs, go ~path rules) - | Finite m -> Finite m - | Thunk t -> - Thunk (fun () -> - print path "thunk"; - t ()) - in - go ~path:[] - end -end diff --git a/src/scheme.mli b/src/scheme.mli index 6b181c51593..89f10acda94 100644 --- a/src/scheme.mli +++ b/src/scheme.mli @@ -1,8 +1,18 @@ +(** A collection of rules for one or multiple directories. *) + open! Stdune -(** [Scheme] is a collection of rules for one or multiple directories. *) +(** Generic representation of a scheme *) +module Gen : sig + type 'rules t = + | Empty + | Union of 'rules t * 'rules t + | Approximation of Dir_set.t * 'rules t + | Finite of 'rules Path.Build.Map.t + | Thunk of (unit -> 'rules t) +end -open Scheme_intf +module type S = Scheme_intf.S with module Gen := Gen module Make(Directory_rules : sig type t @@ -11,14 +21,3 @@ module Make(Directory_rules : sig end) : S with type dir_rules := Directory_rules.t include S with type dir_rules := Rules.rule - -module Gen : sig - module For_tests : sig - (* calls [print] every time any code embedded in the [Scheme] runs, be it - a [Thunk] constructor or an [Approximation] function. - - The argument of [print] identifies which thunk got run (the path to that - thunk within the [Scheme.t] value). *) - val instrument : print:(string -> unit) -> 'a Gen.t -> 'a Gen.t - end -end diff --git a/src/scheme_intf.ml b/src/scheme_intf.ml index 3cd290fdc54..fc2e0b91484 100644 --- a/src/scheme_intf.ml +++ b/src/scheme_intf.ml @@ -1,35 +1,18 @@ open! Stdune -module Gen = struct - type 'rules t = - | Empty - | Union of 'rules t * 'rules t - | Approximation of Dir_set.t * 'rules t - | Finite of 'rules Path.Build.Map.t - | Thunk of (unit -> 'rules t) -end - module type S = sig + module Gen : sig + type 'a t + end type dir_rules - type 'rules t_gen = 'rules Gen.t = - | Empty - | Union of 'rules t_gen * 'rules t_gen - | Approximation of Dir_set.t * 'rules t_gen - | Finite of 'rules Path.Build.Map.t - | Thunk of (unit -> 'rules t_gen) - - type t = dir_rules t_gen + type t = dir_rules Gen.t module Evaluated : sig type t end - module For_tests : sig - val collect_rules_simple : t -> dir:Path.Build.t -> dir_rules - end - val evaluate : t -> Evaluated.t val get_rules : Evaluated.t -> dir:Path.Build.t -> dir_rules diff --git a/test/unit-tests/scheme.mlt b/test/unit-tests/scheme.mlt index 332fd9c27b2..8a7ae6a2c7b 100644 --- a/test/unit-tests/scheme.mlt +++ b/test/unit-tests/scheme.mlt @@ -23,8 +23,59 @@ module Directory_rules = struct end module Scheme = struct - include Dune.Scheme.Gen.For_tests include Dune.Scheme.Make(Directory_rules) + + (* Calls [print] every time any code embedded in the scheme runs, + be it a [Thunk] constructor or an [Approximation] function. + + The argument of [print] identifies which thunk got run (the path + to that thunk within the [Scheme.t] value). *) + let instrument ~print = + let open Dune.Scheme.Gen in + let print path suffix = + print (String.concat (List.rev path @ [suffix]) ~sep:":") + in + let rec go ~path t = match t with + | Empty -> Empty + | Union (t1, t2) -> + Union (go ~path:("l"::path) t1, go ~path:("r"::path) t2) + | Approximation (dirs, rules) -> + let path = "t" :: path in + Approximation (dirs, go ~path rules) + | Finite m -> Finite m + | Thunk t -> + Thunk (fun () -> + print path "thunk"; + t ()) + in + go ~path:[] + + (* [collect_rules_simple] is oversimplified in two ways: + - it does not share the work of scheme flattening, so repeated lookups do + repeated work + - it does not check that approximations are correct + + If approximations are not correct, it will honor the approximation. + So approximations act like views that prevent the rules from being seen + rather than from being declared in the first place. + *) + let collect_rules_simple = + let rec go (t : t) ~dir = + match t with + | Empty -> Directory_rules.empty + | Union (a, b) -> Directory_rules.union(go a ~dir) (go b ~dir) + | Approximation (dirs, t) -> + (match Dune.Dir_set.mem dirs dir with + | true -> go t ~dir + | false -> Directory_rules.empty) + | Finite rules -> + (match Path.Build.Map.find rules dir with + | None -> Directory_rules.empty + | Some rule -> rule) + | Thunk f -> + go (f ()) ~dir + in + go end module Dir_set = Dune.Dir_set @@ -51,7 +102,7 @@ let record_calls scheme ~f = let print_rules scheme ~dir = let res1, calls1 = - record_calls scheme ~f:(Scheme.For_tests.collect_rules_simple ~dir) + record_calls scheme ~f:(Scheme.collect_rules_simple ~dir) in let res2, calls2 = record_calls scheme ~f:(fun scheme -> @@ -90,7 +141,7 @@ open Dune.Scheme let () = let scheme = - Dune.Scheme.Thunk (fun () -> Dune.Scheme.Empty) + Dune.Scheme.Gen.Thunk (fun () -> Dune.Scheme.Gen.Empty) in print_rules scheme ~dir:(Path.of_string "foo/bar") @@ -102,7 +153,7 @@ rules: |}] let scheme_all_but_foo_bar = - Dune.Scheme.Approximation ( + Dune.Scheme.Gen.Approximation ( Dir_set.negate ( Dir_set.subtree (Path.of_string "foo/bar")), Thunk (fun () -> Empty)) From 0662dc6446c89bb096f32abf961db9b06faef7e6 Mon Sep 17 00:00:00 2001 From: Arseniy Alekseyev Date: Mon, 6 May 2019 17:57:07 +0100 Subject: [PATCH 05/11] only expose the polymorphic scheme Signed-off-by: Arseniy Alekseyev --- src/memo/memo.mli | 2 +- src/rules.ml | 9 +- src/rules.mli | 22 ++-- src/scheme.ml | 213 +++++++++++++++++-------------------- src/scheme.mli | 27 +++-- src/scheme_intf.ml | 21 ---- test/unit-tests/scheme.mlt | 15 ++- 7 files changed, 142 insertions(+), 167 deletions(-) delete mode 100644 src/scheme_intf.ml diff --git a/src/memo/memo.mli b/src/memo/memo.mli index cb3fea31ede..41da4b952e7 100644 --- a/src/memo/memo.mli +++ b/src/memo/memo.mli @@ -165,7 +165,7 @@ val registered_functions : unit -> Function_info.t list val function_info : string -> Function_info.t module Lazy : sig - type 'a t + type +'a t val map2 : 'a t -> 'b t -> f:('a -> 'b -> 'c) -> 'c t val bind : 'a t -> f:('a -> 'b t) -> 'b t diff --git a/src/rules.ml b/src/rules.ml index e43d1a9e1de..402d0ea4453 100644 --- a/src/rules.ml +++ b/src/rules.ml @@ -1,9 +1,14 @@ open! Stdune -type rule = unit -> unit +module Dir_rules = struct + type t = unit -> unit + + let empty = (fun () -> ()) + let union f g () = f (); g () +end module T = struct - type t = rule Path.Build.Map.t + type t = Dir_rules.t Path.Build.Map.t let empty = Path.Build.Map.empty diff --git a/src/rules.mli b/src/rules.mli index 6aebc9fcef2..6b3de9cb56d 100644 --- a/src/rules.mli +++ b/src/rules.mli @@ -1,20 +1,26 @@ -(** [Rules] represents a collection of rules across a known set of directories. *) +(** [Rules] represents a collection of rules across a known finite set of + directories. *) open! Stdune -(** [rule] is a function that produces some build system rules - such as ([Build_system.add_rule]) in a known directory. *) -type rule = unit -> unit +module Dir_rules : sig + (** [rule] is a function that produces some build system rules + such as ([Build_system.add_rule]) in a known directory. *) + type t = unit -> unit -type t = private rule Path.Build.Map.t + val empty : t + val union : t -> t -> t +end -val to_map : t -> rule Path.Build.Map.t +type t = private Dir_rules.t Path.Build.Map.t + +val to_map : t -> Dir_rules.t Path.Build.Map.t (* [Path] must be in build directory *) -val file_rule : rule:(Path.t * rule) -> unit +val file_rule : rule:(Path.t * Dir_rules.t) -> unit (* [Path] must be in build directory *) -val dir_rule : (Path.t * rule) -> unit +val dir_rule : (Path.t * Dir_rules.t) -> unit val union : t -> t -> t diff --git a/src/scheme.ml b/src/scheme.ml index d6a46522fdc..d00e84c3d87 100644 --- a/src/scheme.ml +++ b/src/scheme.ml @@ -2,7 +2,7 @@ open! Stdune module Path = Path.Build -module Gen = struct +module T = struct type 'rules t = | Empty | Union of 'rules t * 'rules t @@ -10,106 +10,98 @@ module Gen = struct | Finite of 'rules Path.Map.t | Thunk of (unit -> 'rules t) - module Evaluated = struct - type 'rules t = { - by_child : 'rules t Memo.Lazy.t String.Map.t; - rules_here : 'rules Memo.Lazy.t; - } - end end -open Gen -module type S = Scheme_intf.S with module Gen := Gen +include T + +module Evaluated = struct -module Make(Rules : sig - type t - val empty : t - val union : t -> t -> t - end) = struct - type t = Rules.t Gen.t + type 'rules t = { + by_child : 'rules t Memo.Lazy.t String.Map.t; + rules_here : 'rules option Memo.Lazy.t; + } + + let empty = + { by_child = String.Map.empty; + rules_here = Memo.Lazy.of_val None; + } - module Evaluated = struct - type 'rules t_gen = 'rules Evaluated.t = { - by_child : 'rules t_gen Memo.Lazy.t String.Map.t; - rules_here : 'rules Memo.Lazy.t; + let descend t dir = + match String.Map.find t.by_child dir with + | None -> empty + | Some res -> Memo.Lazy.force res + + let union_option ~f a b = match (a, b) with + | None, x | x, None -> x + | Some x, Some y -> Some (f x y) + + let rec union ~union_rules x y = + { + by_child = + String.Map.union x.by_child y.by_child + ~f:(fun _key data1 data2 -> Some ( + Memo.Lazy.map2 data1 data2 + ~f:(fun x y -> union ~union_rules x y))); + rules_here = + Memo.Lazy.map2 x.rules_here y.rules_here ~f:( + union_option ~f:union_rules) } - type t = Rules.t t_gen - - let empty = - { by_child = String.Map.empty; - rules_here = Memo.Lazy.of_val Rules.empty; - } - - let descend t dir = - match String.Map.find t.by_child dir with - | None -> empty - | Some res -> Memo.Lazy.force res - - let rec union ~union_rules x y = - { - by_child = - String.Map.union x.by_child y.by_child - ~f:(fun _key data1 data2 -> Some ( - Memo.Lazy.map2 data1 data2 - ~f:(fun x y -> union ~union_rules x y))); - rules_here = - Memo.Lazy.map2 x.rules_here y.rules_here ~f:union_rules - } - - let union = union ~union_rules:Rules.union - - let rec restrict (dirs : Dir_set.t) t : t = - { - rules_here = - (if Dir_set.here dirs then - Memo.Lazy.bind t ~f:(fun t -> t.rules_here) - else - Memo.Lazy.of_val Rules.empty); - by_child = - (match Dir_set.default dirs with - | true -> - (* This is forcing the lazy potentially too early if the directory - the user is interested in is not actually in the set. We're not - fully committed to supporting this case though, anyway. *) - String.Map.mapi (Memo.Lazy.force t).by_child - ~f:(fun dir v -> - Memo.lazy_ (fun () -> - restrict - (Dir_set.descend dirs dir) - v)) - | false -> - String.Map.mapi (Dir_set.exceptions dirs) - ~f:(fun dir v -> - Memo.lazy_ (fun () -> - restrict - v - (Memo.lazy_ (fun () -> - descend (Memo.Lazy.force t) dir))))); - } - - let singleton path (rules : Rules.t) = - let rec go = function - | [] -> - { by_child = String.Map.empty; rules_here = Memo.Lazy.of_val rules; } - | x :: xs -> - { - by_child = String.Map.singleton x (Memo.Lazy.of_val (go xs)); - rules_here = Memo.Lazy.of_val Rules.empty; - } - in - go (Path.explode path) - - let finite m = - Path.Map.to_list m - |> List.map ~f:(fun (path, rules) -> - singleton path rules) - |> List.fold_left ~init:empty ~f:union - - end - - let rec evaluate ~env = function + + let rec restrict (dirs : Dir_set.t) t : _ t = + { + rules_here = + (if Dir_set.here dirs then + Memo.Lazy.bind t ~f:(fun t -> t.rules_here) + else + Memo.Lazy.of_val None); + by_child = + (match Dir_set.default dirs with + | true -> + (* This is forcing the lazy potentially too early if the directory + the user is interested in is not actually in the set. We're not + fully committed to supporting this case though, anyway. *) + String.Map.mapi (Memo.Lazy.force t).by_child + ~f:(fun dir v -> + Memo.lazy_ (fun () -> + restrict + (Dir_set.descend dirs dir) + v)) + | false -> + String.Map.mapi (Dir_set.exceptions dirs) + ~f:(fun dir v -> + Memo.lazy_ (fun () -> + restrict + v + (Memo.lazy_ (fun () -> + descend (Memo.Lazy.force t) dir))))); + } + + let singleton path rules = + let rec go = function + | [] -> + { by_child = String.Map.empty; + rules_here = Memo.Lazy.of_val (Some rules); } + | x :: xs -> + { + by_child = String.Map.singleton x (Memo.Lazy.of_val (go xs)); + rules_here = Memo.Lazy.of_val None; + } + in + go (Path.explode path) + + let finite ~union_rules m = + Path.Map.to_list m + |> List.map ~f:(fun (path, rules) -> + singleton path rules) + |> List.fold_left ~init:empty ~f:(union ~union_rules) + +end + +let evaluate ~union_rules ~env = + let rec loop = function | Empty -> Evaluated.empty - | Union (x, y) -> Evaluated.union (evaluate ~env x) (evaluate ~env y) + | Union (x, y) -> + Evaluated.union ~union_rules (loop x) (loop y) | Approximation (paths, rules) -> if not (Dir_set.is_subset paths ~of_:env) @@ -126,26 +118,17 @@ module Make(Rules : sig else let paths = Dir_set.inter paths env in Evaluated.restrict paths - (Memo.lazy_ (fun () -> evaluate ~env:paths rules)) - | Finite rules -> Evaluated.finite rules - | Thunk f -> evaluate ~env (f ()) - - let all l = List.fold_left ~init:Empty ~f:(fun x y -> Union (x, y)) l + (Memo.lazy_ (fun () -> loop rules)) + | Finite rules -> Evaluated.finite ~union_rules rules + | Thunk f -> loop (f ()) + in + fun t -> loop t - let get_rules : Evaluated.t -> dir:Path.t -> Rules.t = - fun t ~dir -> - let dir = Path.explode dir in - let t = List.fold_left dir ~init:t ~f:Evaluated.descend in - Memo.Lazy.force t.rules_here - - let evaluate = evaluate ~env:Dir_set.universal - -end +let all l = List.fold_left ~init:Empty ~f:(fun x y -> Union (x, y)) l -module Rules_scheme = Make(struct - type t = unit -> unit - let empty = (fun () -> ()) - let union f g () = f (); g () - end) +let get_rules t ~dir = + let dir = Path.explode dir in + let t = List.fold_left dir ~init:t ~f:Evaluated.descend in + Memo.Lazy.force t.rules_here -include Rules_scheme +let evaluate t ~union = evaluate ~union_rules:union ~env:Dir_set.universal t diff --git a/src/scheme.mli b/src/scheme.mli index 89f10acda94..da3e795344b 100644 --- a/src/scheme.mli +++ b/src/scheme.mli @@ -2,22 +2,19 @@ open! Stdune -(** Generic representation of a scheme *) -module Gen : sig - type 'rules t = - | Empty - | Union of 'rules t * 'rules t - | Approximation of Dir_set.t * 'rules t - | Finite of 'rules Path.Build.Map.t - | Thunk of (unit -> 'rules t) +type 'rules t = + | Empty + | Union of 'rules t * 'rules t + | Approximation of Dir_set.t * 'rules t + | Finite of 'rules Path.Build.Map.t + | Thunk of (unit -> 'rules t) + +module Evaluated : sig + type 'a t end -module type S = Scheme_intf.S with module Gen := Gen +val evaluate : 'a t -> union:('a -> 'a -> 'a) -> 'a Evaluated.t -module Make(Directory_rules : sig - type t - val empty : t - val union : t -> t -> t - end) : S with type dir_rules := Directory_rules.t +val get_rules : 'a Evaluated.t -> dir:Path.Build.t -> 'a option -include S with type dir_rules := Rules.rule +val all : 'a t list -> 'a t diff --git a/src/scheme_intf.ml b/src/scheme_intf.ml deleted file mode 100644 index fc2e0b91484..00000000000 --- a/src/scheme_intf.ml +++ /dev/null @@ -1,21 +0,0 @@ -open! Stdune - -module type S = sig - module Gen : sig - type 'a t - end - - type dir_rules - - type t = dir_rules Gen.t - - module Evaluated : sig - type t - end - - val evaluate : t -> Evaluated.t - - val get_rules : Evaluated.t -> dir:Path.Build.t -> dir_rules - - val all : t list -> t -end diff --git a/test/unit-tests/scheme.mlt b/test/unit-tests/scheme.mlt index 8a7ae6a2c7b..177f25a499b 100644 --- a/test/unit-tests/scheme.mlt +++ b/test/unit-tests/scheme.mlt @@ -23,7 +23,7 @@ module Directory_rules = struct end module Scheme = struct - include Dune.Scheme.Make(Directory_rules) + include Dune.Scheme (* Calls [print] every time any code embedded in the scheme runs, be it a [Thunk] constructor or an [Approximation] function. @@ -31,7 +31,6 @@ module Scheme = struct The argument of [print] identifies which thunk got run (the path to that thunk within the [Scheme.t] value). *) let instrument ~print = - let open Dune.Scheme.Gen in let print path suffix = print (String.concat (List.rev path @ [suffix]) ~sep:":") in @@ -60,7 +59,7 @@ module Scheme = struct rather than from being declared in the first place. *) let collect_rules_simple = - let rec go (t : t) ~dir = + let rec go (t : _ t) ~dir = match t with | Empty -> Directory_rules.empty | Union (a, b) -> Directory_rules.union(go a ~dir) (go b ~dir) @@ -76,6 +75,12 @@ module Scheme = struct go (f ()) ~dir in go + + let evaluate = evaluate ~union:Directory_rules.union + + let get_rules t ~dir = + Option.value (get_rules t ~dir) + ~default:Directory_rules.empty end module Dir_set = Dune.Dir_set @@ -141,7 +146,7 @@ open Dune.Scheme let () = let scheme = - Dune.Scheme.Gen.Thunk (fun () -> Dune.Scheme.Gen.Empty) + Scheme.Thunk (fun () -> Scheme.Empty) in print_rules scheme ~dir:(Path.of_string "foo/bar") @@ -153,7 +158,7 @@ rules: |}] let scheme_all_but_foo_bar = - Dune.Scheme.Gen.Approximation ( + Scheme.Approximation ( Dir_set.negate ( Dir_set.subtree (Path.of_string "foo/bar")), Thunk (fun () -> Empty)) From 8ac35a281ea461036d7a816d31ff27432aeb2dd0 Mon Sep 17 00:00:00 2001 From: Jeremie Dimino Date: Tue, 7 May 2019 12:13:01 +0100 Subject: [PATCH 06/11] Move get_rules to Evaluated Signed-off-by: Jeremie Dimino --- src/scheme.ml | 9 ++++----- src/scheme.mli | 4 ++-- test/unit-tests/scheme.mlt | 2 +- 3 files changed, 7 insertions(+), 8 deletions(-) diff --git a/src/scheme.ml b/src/scheme.ml index d00e84c3d87..6f66e1ae5f8 100644 --- a/src/scheme.ml +++ b/src/scheme.ml @@ -95,6 +95,10 @@ module Evaluated = struct singleton path rules) |> List.fold_left ~init:empty ~f:(union ~union_rules) + let get_rules t ~dir = + let dir = Path.explode dir in + let t = List.fold_left dir ~init:t ~f:descend in + Memo.Lazy.force t.rules_here end let evaluate ~union_rules ~env = @@ -126,9 +130,4 @@ let evaluate ~union_rules ~env = let all l = List.fold_left ~init:Empty ~f:(fun x y -> Union (x, y)) l -let get_rules t ~dir = - let dir = Path.explode dir in - let t = List.fold_left dir ~init:t ~f:Evaluated.descend in - Memo.Lazy.force t.rules_here - let evaluate t ~union = evaluate ~union_rules:union ~env:Dir_set.universal t diff --git a/src/scheme.mli b/src/scheme.mli index da3e795344b..67623e1daaf 100644 --- a/src/scheme.mli +++ b/src/scheme.mli @@ -11,10 +11,10 @@ type 'rules t = module Evaluated : sig type 'a t + + val get_rules : 'a t -> dir:Path.Build.t -> 'a option end val evaluate : 'a t -> union:('a -> 'a -> 'a) -> 'a Evaluated.t -val get_rules : 'a Evaluated.t -> dir:Path.Build.t -> 'a option - val all : 'a t list -> 'a t diff --git a/test/unit-tests/scheme.mlt b/test/unit-tests/scheme.mlt index 177f25a499b..0310c6b53fe 100644 --- a/test/unit-tests/scheme.mlt +++ b/test/unit-tests/scheme.mlt @@ -79,7 +79,7 @@ module Scheme = struct let evaluate = evaluate ~union:Directory_rules.union let get_rules t ~dir = - Option.value (get_rules t ~dir) + Option.value (Evaluated.get_rules t ~dir) ~default:Directory_rules.empty end From a724cc579197e28a352e4837cac82311c007cf25 Mon Sep 17 00:00:00 2001 From: Jeremie Dimino Date: Tue, 7 May 2019 13:15:44 +0100 Subject: [PATCH 07/11] Exn.code_error already raises Signed-off-by: Jeremie Dimino --- src/scheme.ml | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/src/scheme.ml b/src/scheme.ml index 6f66e1ae5f8..a6c49428ace 100644 --- a/src/scheme.ml +++ b/src/scheme.ml @@ -111,14 +111,14 @@ let evaluate ~union_rules ~env = not (Dir_set.is_subset paths ~of_:env) && not (Dir_set.is_subset (Dir_set.negate paths) ~of_:env) then - raise (Exn.code_error - "inner [Approximate] specifies a set such that neither it, \ - nor its negation, are a subset of directories specified by \ - the outer [Approximate]." - [ - "inner", (Dir_set.to_sexp paths); - "outer", (Dir_set.to_sexp env); - ]) + Exn.code_error + "inner [Approximate] specifies a set such that neither it, \ + nor its negation, are a subset of directories specified by \ + the outer [Approximate]." + [ + "inner", (Dir_set.to_sexp paths); + "outer", (Dir_set.to_sexp env); + ] else let paths = Dir_set.inter paths env in Evaluated.restrict paths From d8deae9c6e6b6dd0c20b80cd96a02b21d15775c7 Mon Sep 17 00:00:00 2001 From: Rudi Grinberg Date: Tue, 7 May 2019 20:36:07 +0800 Subject: [PATCH 08/11] Add tuareg header line to scheme.mlt Signed-off-by: Rudi Grinberg --- test/unit-tests/scheme.mlt | 1 + 1 file changed, 1 insertion(+) diff --git a/test/unit-tests/scheme.mlt b/test/unit-tests/scheme.mlt index 0310c6b53fe..b3a50bf60d9 100644 --- a/test/unit-tests/scheme.mlt +++ b/test/unit-tests/scheme.mlt @@ -1,3 +1,4 @@ +(* -*- tuareg -*- *) open Stdune let print = Printf.printf "%s\n" From 105c42562e49cd30896b1946e8674b98ec3a9457 Mon Sep 17 00:00:00 2001 From: Arseniy Alekseyev Date: Tue, 7 May 2019 14:00:58 +0100 Subject: [PATCH 09/11] simplify union Signed-off-by: Arseniy Alekseyev --- src/rules.ml | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/src/rules.ml b/src/rules.ml index 402d0ea4453..d1d811f96b3 100644 --- a/src/rules.ml +++ b/src/rules.ml @@ -15,8 +15,7 @@ module T = struct let union_map a b ~f = Path.Build.Map.union a b ~f:(fun _key a b -> Some (f a b)) - let union = - union_map ~f:(fun rule1 rule2 -> fun () -> rule1 (); rule2 ()) + let union = union_map ~f:Dir_rules.union let name = "Rules" end From 2f45b22c211326170b8adcf7951d4cc0830b66b7 Mon Sep 17 00:00:00 2001 From: Arseniy Alekseyev Date: Tue, 7 May 2019 16:12:18 +0100 Subject: [PATCH 10/11] fix bug Signed-off-by: Arseniy Alekseyev --- src/scheme.ml | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/src/scheme.ml b/src/scheme.ml index a6c49428ace..1dc29a23fe2 100644 --- a/src/scheme.ml +++ b/src/scheme.ml @@ -101,11 +101,11 @@ module Evaluated = struct Memo.Lazy.force t.rules_here end -let evaluate ~union_rules ~env = - let rec loop = function +let evaluate ~union_rules = + let rec loop ~env = function | Empty -> Evaluated.empty | Union (x, y) -> - Evaluated.union ~union_rules (loop x) (loop y) + Evaluated.union ~union_rules (loop ~env x) (loop ~env y) | Approximation (paths, rules) -> if not (Dir_set.is_subset paths ~of_:env) @@ -122,12 +122,12 @@ let evaluate ~union_rules ~env = else let paths = Dir_set.inter paths env in Evaluated.restrict paths - (Memo.lazy_ (fun () -> loop rules)) + (Memo.lazy_ (fun () -> loop ~env:paths rules)) | Finite rules -> Evaluated.finite ~union_rules rules - | Thunk f -> loop (f ()) + | Thunk f -> loop ~env (f ()) in - fun t -> loop t + fun t -> loop ~env:Dir_set.universal t let all l = List.fold_left ~init:Empty ~f:(fun x y -> Union (x, y)) l -let evaluate t ~union = evaluate ~union_rules:union ~env:Dir_set.universal t +let evaluate t ~union = evaluate ~union_rules:union t From d50f66801de4543877dcbf04993de6b35944df13 Mon Sep 17 00:00:00 2001 From: Arseniy Alekseyev Date: Tue, 7 May 2019 16:25:16 +0100 Subject: [PATCH 11/11] check it when scheme tries to break out of its env Signed-off-by: Arseniy Alekseyev --- src/scheme.ml | 13 ++++++++++++- 1 file changed, 12 insertions(+), 1 deletion(-) diff --git a/src/scheme.ml b/src/scheme.ml index 1dc29a23fe2..f8af7b71343 100644 --- a/src/scheme.ml +++ b/src/scheme.ml @@ -123,7 +123,18 @@ let evaluate ~union_rules = let paths = Dir_set.inter paths env in Evaluated.restrict paths (Memo.lazy_ (fun () -> loop ~env:paths rules)) - | Finite rules -> Evaluated.finite ~union_rules rules + | Finite rules -> + let violations = + List.filter (Path.Map.keys rules) ~f:(fun p -> not (Dir_set.mem env p)) + in + (match violations with + | [] -> () + | _ :: _ -> + Exn.code_error + "Scheme attempted to generate rules in a directory it promised not \ + to touch" + [ "directories", (Sexp.Encoder.list Path.to_sexp) violations ]); + Evaluated.finite ~union_rules rules | Thunk f -> loop ~env (f ()) in fun t -> loop ~env:Dir_set.universal t