Introduce scheme (#2086)

* Introduce Scheme

Signed-off-by: Jeremie Dimino <jeremie@dimino.org>
Signed-off-by: Arseniy Alekseyev <aalekseyev@janestreet.com>

src/dir_set.ml

@@ -0,0 +1,180 @@
+open! Stdune
+
+type t =
+  | Empty
+  | Universal
+  | Nontrivial of nontrivial
+and nontrivial = {
+  default : bool;
+  here : bool;
+  exceptions : t String.Map.t;
+}
+
+let here = function
+  | Empty -> false
+  | Universal -> true
+  | Nontrivial t -> t.here
+
+let default = function
+  | Empty -> false
+  | Universal -> true
+  | Nontrivial t -> t.default
+
+let exceptions = function
+  | Empty | Universal -> String.Map.empty
+  | Nontrivial t -> t.exceptions
+
+let empty = Empty
+let universal = Universal
+
+let trivial = function
+  | false -> Empty
+  | true -> Universal
+
+let create ~default ~here ~exceptions =
+  if String.Map.is_empty exceptions && here = default then
+    trivial default
+  else
+    Nontrivial { here; default; exceptions }
+
+let is_empty = function
+  | Empty -> true
+  | _ -> false
+
+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, v | v, Empty -> v
+  | Universal, _ | _, Universal -> Universal
+  | Nontrivial x, Nontrivial y ->
+    merge_nontrivial x y ~f_one:(||) ~f_set:union
+
+let rec inter x y =
+  match x, y with
+  | Universal, v | v, Universal -> v
+  | Empty, _ | _, Empty -> Empty
+  | Nontrivial x, Nontrivial y ->
+    merge_nontrivial x y ~f_one:(&&) ~f_set:inter
+
+let rec negate x =
+  match x with
+  | 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 { 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 =
+  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 =
+  let rec loop subtree = function
+    | [] -> subtree
+    | component :: rest ->
+      create
+        ~here:false
+        ~default:false
+        ~exceptions:(String.Map.singleton component (loop subtree rest))
+  in
+  fun subtree path -> loop subtree (Path.Build.explode path)
+
+let just_the_root =
+  Nontrivial
+    { here = true
+    ; default = false
+    ; exceptions = String.Map.empty
+    }
+
+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 { here; default; exceptions } ->
+    Sexp.List (
+      (
+        (match here with | true -> [ ".", Sexp.Atom "true" ] | false -> []) @
+        (String.Map.to_list exceptions
+         |> List.map ~f:(fun (s, t) ->
+           s, to_sexp t)) @
+        (match default with
+         | false -> []
+         | true -> [("*", Sexp.Atom "Universal")]))
+      |> List.map ~f:(fun (k, v) -> Sexp.List [Sexp.Atom k; v]))

src/dir_set.mli

@@ -0,0 +1,71 @@
+(** Potentially infinite sets of directories *)
+
+open! Stdune
+
+(** Type of potentially infinite sets of directories. Not all sets can
+    be represented, only ones that can be efficiently inspected. *)
+type t
+
+(** [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
+
+(** 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
+
+(** [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
+
+(** [exceptions t] is the set of all bindings of the form [(comp,
+    t']] such that:
+
+    - [t' = descend t comp]
+    - [t' <> trivial (default t)]
+
+    Sets of directories for which [exceptions t] is not finite cannot be
+    represented by this module.
+*)
+val exceptions : t -> t String.Map.t
+
+(** 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 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

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

src/memo/memo.mli

@@ -165,7 +165,10 @@ 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
 
   val create : (unit -> 'a) -> 'a t
   val of_val : 'a -> 'a t

src/rules.ml

@@ -0,0 +1,45 @@
+open! Stdune
+
+module Dir_rules = struct
+  type t = unit -> unit
+
+  let empty = (fun () -> ())
+  let union f g () = f (); g ()
+end
+
+module T = struct
+  type t = Dir_rules.t 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:Dir_rules.union
+
+  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

src/rules.mli

@@ -0,0 +1,27 @@
+(** [Rules] represents a collection of rules across a known finite set of
+    directories. *)
+
+open! Stdune
+
+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
+
+  val empty : t
+  val union : t -> t -> t
+end
+
+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 * Dir_rules.t) -> unit
+
+(* [Path] must be in build directory *)
+val dir_rule : (Path.t * Dir_rules.t) -> unit
+
+val union : t -> t -> t
+
+val collect : (unit -> 'a) -> ('a * t)