Adds support for globs in dune-action-plugin.

Signed-off-by: Jakub Staron <jstaron@janestreet.com>

src/dune/action_exec.ml

@@ -19,6 +19,8 @@ module Dynamic_dep = struct
       function
       | File fn -> File (to_dune_path fn)
       | Directory dir -> Glob (to_dune_path dir, Glob.universal)
+      | Glob { path; glob } ->
+        Glob (to_dune_path path, Glob.of_string_exn Loc.none glob)
 
     let compare x y =
       match (x, y) with

src/dune/dune

@@ -4,11 +4,11 @@
  (name dune)
  (libraries unix stdune fiber incremental_cycles dag memo xdg dune_re
    threads.posix opam_file_format dune_lang dune_manager dune_memory
-   ocaml_config catapult jbuild_support dune_action_plugin)
+   dune_glob_lexer ocaml_config catapult jbuild_support dune_action_plugin)
  (synopsis "Internal Dune library, do not use!")
  (preprocess future_syntax))
 
-(ocamllex glob_lexer dune_lexer ocamlobjinfo)
+(ocamllex dune_lexer ocamlobjinfo)
 
 (rule
  (targets setup.ml)

src/dune/glob.ml

@@ -15,7 +15,7 @@ let hash t = String.hash t.repr
 let to_dyn t = Dyn.Encoder.string t.repr
 
 let of_string repr =
-  Glob_lexer.parse_string repr
+  Dune_glob_lexer.parse_string repr
   |> Result.map ~f:(fun re -> { re = Re.compile re; repr })
 
 let of_string_exn loc repr =

src/dune_action_plugin/dune

@@ -1,6 +1,6 @@
 (library
  (name dune_action_plugin)
  (public_name dune._dune_action_plugin)
- (libraries stdune)
+ (libraries stdune dune_re dune_glob_lexer)
  (synopsis
    "Monadic interface for defining scripts with dynamic or complex set of depencencies."))

src/dune_action_plugin/dune_action_plugin.ml

@@ -1,4 +1,5 @@
 module Path = Path
+module Glob = Glob
 open Protocol
 
 module Execution_error = struct
@@ -123,6 +124,19 @@ let read_directory ~path =
     ; targets = Stdune.String.Set.empty
     }
 
+let read_directory_with_glob ~path ~glob =
+  let path = Path.to_string path in
+  let action () =
+    Fs.read_directory path |> Execution_error.raise_on_fs_error
+    |> List.filter (Glob.test glob)
+  in
+  lift_stage
+    { action
+    ; dependencies =
+        Dependency.Set.singleton (Glob { path; glob = Glob.to_string glob })
+    ; targets = Stdune.String.Set.empty
+    }
+
 let rec run_by_dune t context =
   match t with
   | Pure () -> Context.respond context Done

src/dune_action_plugin/dune_action_plugin.mli

@@ -8,6 +8,7 @@
     [stage] to discourage people from overusing it. *)
 
 module Path = Path
+module Glob = Glob
 
 type 'a t
 
@@ -63,6 +64,11 @@ val write_file : path:Path.t -> data:string -> unit t
     directory. Computation will result in a directory listing. *)
 val read_directory : path:Path.t -> string list t
 
+(** [read_directory_with_glob ~path:directory ~glob] returns a computation
+    depending on a listing of a [directory] filtered by glob and resulting in
+    that listing. *)
+val read_directory_with_glob : path:Path.t -> glob:Glob.t -> string list t
+
 (** {1:running Running the computation} *)
 
 (** Runs the computation. This function never returns. *)

src/dune_action_plugin/glob.ml

@@ -0,0 +1,19 @@
+open Stdune
+
+type t =
+  { re : Dune_re.re
+  ; repr : string
+  }
+
+let test t = Dune_re.execp t.re
+
+let of_string repr =
+  let result =
+    Dune_glob_lexer.parse_string repr
+    |> Result.map ~f:(fun re -> { re = Dune_re.compile re; repr })
+  in
+  match result with
+  | Error (_, msg) -> invalid_arg (Printf.sprintf "invalid glob: :%s" msg)
+  | Ok t -> t
+
+let to_string (t : t) = t.repr

src/dune_action_plugin/glob.mli

@@ -0,0 +1,13 @@
+(** Simple glob support library. *)
+
+type t
+
+(** Tests if string matches the glob. *)
+val test : t -> string -> bool
+
+(** Returns textual representation of a glob. *)
+val to_string : t -> string
+
+(** Converts string to glob. Throws [Invalid_argument] exception if string is
+    not a valid glob. *)
+val of_string : string -> t

src/dune_action_plugin/protocol.ml

@@ -19,14 +19,21 @@ module Dependency = struct
     type t =
       | File of string
       | Directory of string
+      | Glob of
+          { path : string
+          ; glob : string
+          }
 
     let sexp_of_t : _ -> Sexp.t = function
       | File path -> List [ Atom "file"; Atom path ]
       | Directory path -> List [ Atom "directory"; Atom path ]
+      | Glob { path; glob } -> List [ Atom "glob"; Atom path; Atom glob ]
 
     let t_of_sexp : Sexp.t -> _ = function
       | List [ Atom "file"; Atom path ] -> Some (File path)
       | List [ Atom "directory"; Atom path ] -> Some (Directory path)
+      | List [ Atom "glob"; Atom path; Atom glob ] ->
+        Some (Glob { path; glob })
       | _ -> None
 
     let compare x y =
@@ -35,6 +42,13 @@ module Dependency = struct
       | File _, _ -> Lt
       | _, File _ -> Gt
       | Directory x, Directory y -> String.compare x y
+      | Directory _, _ -> Lt
+      | _, Directory _ -> Gt
+      | ( Glob { path = path1; glob = glob1 }
+        , Glob { path = path2; glob = glob2 } ) -> (
+        match String.compare path1 path2 with
+        | Eq -> String.compare glob1 glob2
+        | not_eq -> not_eq )
 
     let to_dyn _ = Dyn.opaque
   end

src/dune_action_plugin/protocol.mli

@@ -6,6 +6,10 @@ module Dependency : sig
   type t =
     | File of string
     | Directory of string
+    | Glob of
+        { path : string
+        ; glob : string
+        }
 
   include Sexpable with type t := t
 

src/dune_glob_lexer/dune

@@ -0,0 +1,8 @@
+(library
+ (name        dune_glob_lexer)
+ (public_name dune._dune_glob_lexer)
+ (flags       (:standard -w -50))
+ (synopsis "Internal Dune library, do not use!")
+ (libraries stdune dune_re))
+
+ (ocamllex dune_glob_lexer)

src/dune/glob_lexer.mll → src/dune_glob_lexer/dune_glob_lexer.mll

@@ -65,4 +65,3 @@ and char_set st = parse
     | exception Failure msg ->
       Error (Lexing.lexeme_start lb, msg)
 }
-

test/blackbox-tests/test-cases-with-libs/dune-action-plugin/depends-on-directory-with-glob/bin/dune

@@ -0,0 +1,3 @@
+(executables
+ (names foo)
+ (libraries dune_action_plugin))

test/blackbox-tests/test-cases-with-libs/dune-action-plugin/depends-on-directory-with-glob/bin/foo.ml

@@ -0,0 +1,11 @@
+open Dune_action_plugin
+
+let action =
+  let open Dune_action_plugin.O in
+  let glob = Glob.of_string "some_file*" in
+  let+ listing =
+    read_directory_with_glob ~path:(Path.of_string "some_dir") ~glob
+  in
+  String.concat "\n" listing |> print_endline
+
+let () = run action

test/blackbox-tests/test-cases-with-libs/dune-action-plugin/depends-on-directory-with-glob/dune

@@ -0,0 +1,19 @@
+(data_only_dirs test)
+
+(alias
+ (name run_dynamic)
+ (deps
+  (package dune)
+  (source_tree test/)
+  (glob_files bin/*.exe))
+ (action
+  (chdir
+   test
+   (progn
+    (run %{bin:cram} -test run.t)
+    (diff? run.t run.t.corrected)))))
+
+(alias
+ (name runtest)
+ (deps
+  (alias run_dynamic)))

test/blackbox-tests/test-cases-with-libs/dune-action-plugin/depends-on-directory-with-glob/test/run.t

@@ -0,0 +1,42 @@
+  $ echo "(lang dune 2.0)" > dune-project
+
+  $ cat > dune << EOF
+  > (alias
+  >  (name runtest)
+  >  (action (dynamic-run ./foo.exe)))
+  > EOF
+
+  $ mkdir some_dir
+
+  $ cat > some_dir/dune << EOF
+  > (rule
+  >  (target some_file)
+  >  (action
+  >   (progn
+  >    (echo "Building some_file!\n")
+  >    (with-stdout-to %{target} (echo "")))))
+  > \
+  > (rule
+  >  (target another_file)
+  >  (action
+  >   (progn
+  >    (echo "SHOULD NOT BE PRINTED!")
+  >    (with-stdout-to %{target} (echo "")))))
+  > \
+  > (rule
+  >  (target some_file_but_different)
+  >  (action
+  >   (progn
+  >    (echo "Building some_file_but_different!\n")
+  >    (with-stdout-to %{target} (echo "")))))
+  > EOF
+
+  $ cp ../bin/foo.exe ./
+
+  $ dune runtest --display short
+           foo alias runtest
+  Building some_file!
+  Building some_file_but_different!
+           foo alias runtest
+  some_file
+  some_file_but_different

vendor/re/src/dune

@@ -1,6 +1,7 @@
 (library
- (name     dune_re)
- (flags    (:standard -w -50))
+ (name        dune_re)
+ (public_name dune._dune_re)
+ (flags       (:standard -w -50))
  (synopsis "Internal Dune library, do not use!"))
 
 (rule (with-stdout-to dune_re.ml (echo "include Re")))