Delay expansion errors for rules

Previosuly, a failed expansion would immediately fail generating a rule. Now, we delay the error using a [Build.fail]. Signed-off-by: Rudi Grinberg <me@rgrinberg.com>
ocaml · Mar 14, 2020 · 4df13fe · 4df13fe
1 parent 666629f
commit 4df13fe
Show file tree

Hide file tree

Showing 5 changed files with 148 additions and 78 deletions.
diff --git a/CHANGES.md b/CHANGES.md
@@ -1,3 +1,9 @@
+Unreleased
+----------
+
+- Delay expansion errors until the rule is used to build something (#..., fix
+  #3252, @rgrinberg)
+
 2.4.0 (06/03/2020)
 ------------------
 

diff --git a/src/dune/expander.ml b/src/dune/expander.ml
@@ -217,6 +217,23 @@ let expand_path t sw =
 let expand_str t sw =
   expand t ~mode:Single ~template:sw |> Value.to_string ~dir:(Path.build t.dir)
 
+module Partial = struct
+  let expand t ~mode ~template =
+    String_with_vars.partial_expand ~dir:(Path.build t.dir) ~mode template
+      ~f:(expand_var_exn t)
+
+  let expand_path t sw =
+    expand t ~mode:Single ~template:sw
+    |> String_with_vars.Partial.map
+         ~f:
+           (Value.to_path ~error_loc:(String_with_vars.loc sw)
+              ~dir:(Path.build t.dir))
+
+  let expand_str t sw =
+    expand t ~mode:Single ~template:sw
+    |> String_with_vars.Partial.map ~f:(Value.to_string ~dir:(Path.build t.dir))
+end
+
 type reduced_var_result =
   | Unknown
   | Restricted
@@ -245,14 +262,17 @@ module Resolved_forms = struct
       mutable ddeps : Value.t list Build.t Pform.Expansion.Map.t
     }
 
-  let failures t = t.failures
-
   let lib_deps t = t.lib_deps
 
   let sdeps t = t.sdeps
 
   let ddeps t = t.ddeps
 
+  let prefix_failures t b =
+    match t.failures with
+    | [] -> b
+    | fail :: _ -> Build.O.( >>> ) (Build.fail fail) b
+
   let empty () =
     { failures = []
     ; lib_deps = Lib_name.Map.empty
@@ -322,11 +342,6 @@ let expand_and_record acc ~map_exe ~dep_kind ~expansion_kind
     | Static -> fun _ -> User_error.raise ~loc [ cannot_be_used_here pform ]
     | Dynamic -> Resolved_forms.add_ddep acc expansion
   in
-  let add_fail =
-    match expansion_kind with
-    | Static -> fun _ (f : fail) -> f.fail ()
-    | Dynamic -> Resolved_forms.add_fail
-  in
   let open Build.O in
   match (expansion : Pform.Expansion.t) with
   | Var
@@ -357,7 +372,7 @@ let expand_and_record acc ~map_exe ~dep_kind ~expansion_kind
   | Macro (Dep, s) -> Some (path_exp (relative dir s))
   | Macro (Bin, s) -> (
     match resolve_binary ~loc:(Some loc) t ~prog:s with
-    | Error fail -> add_fail acc fail
+    | Error fail -> Resolved_forms.add_fail acc fail
     | Ok path -> Some (path_exp path) )
   | Macro (Lib { lib_exec; lib_private }, s) -> (
     let lib, file = parse_lib_file ~loc s in
@@ -409,24 +424,25 @@ let expand_and_record acc ~map_exe ~dep_kind ~expansion_kind
                path_exp path)
         in
         add_ddep dep
-    | Error e -> (
-      match lib_private with
-      | true -> add_fail acc { fail = (fun () -> raise e) }
-      | false ->
-        if Lib.DB.available (Scope.libs t.scope) lib then
-          let fail () =
-            raise
-              (User_error.raise ~loc
-                 [ Pp.textf
-                     "The library %S is not public. The variable \"lib\" \
-                      expands to the file's installation path which is not \
-                      defined for private libraries."
-                     (Lib_name.to_string lib)
-                 ])
-          in
-          add_fail acc { fail }
-        else
-          add_fail acc { fail = (fun () -> raise e) } ) )
+    | Error e ->
+      Resolved_forms.add_fail acc
+        ( match lib_private with
+        | true -> { fail = (fun () -> raise e) }
+        | false ->
+          if Lib.DB.available (Scope.libs t.scope) lib then
+            { fail =
+                (fun () ->
+                  raise
+                    (User_error.raise ~loc
+                       [ Pp.textf
+                           "The library %S is not public. The variable \"lib\" \
+                            expands to the file's installation path which is \
+                            not defined for private libraries."
+                           (Lib_name.to_string lib)
+                       ]))
+            }
+          else
+            { fail = (fun () -> raise e) } ) )
   | Macro (Lib_available, s) ->
     let lib = Lib_name.parse_string_exn (loc, s) in
     Resolved_forms.add_lib_dep acc lib Optional;

diff --git a/src/dune/expander.mli b/src/dune/expander.mli
@@ -62,6 +62,18 @@ val expand_path : t -> String_with_vars.t -> Path.t
 
 val expand_str : t -> String_with_vars.t -> string
 
+module Partial : sig
+  val expand :
+       t
+    -> mode:'a String_with_vars.Mode.t
+    -> template:String_with_vars.t
+    -> 'a String_with_vars.Partial.t
+
+  val expand_path : t -> String_with_vars.t -> Path.t String_with_vars.Partial.t
+
+  val expand_str : t -> String_with_vars.t -> string String_with_vars.Partial.t
+end
+
 val resolve_binary :
   t -> loc:Loc.t option -> prog:string -> (Path.t, Import.fail) Result.t
 
@@ -79,8 +91,8 @@ module Resolved_forms : sig
       we've discovered. *)
   type t
 
-  (* Failed resolutions *)
-  val failures : t -> Import.fail list
+  (* Prefix with failud resolutions (if present) *)
+  val prefix_failures : t -> 'a Build.t -> 'a Build.t
 
   (* All "name" for %{lib:name:...}/%{lib-available:name} forms *)
   val lib_deps : t -> Lib_deps_info.t

diff --git a/src/dune/super_context.ml b/src/dune/super_context.ml
@@ -602,48 +602,73 @@ module Deps = struct
 
   let make_alias expander s =
     let loc = String_with_vars.loc s in
-    Expander.expand_path expander s |> Alias.of_user_written_path ~loc
+    Expander.Partial.expand_path expander s
+    |> String_with_vars.Partial.map ~f:(Alias.of_user_written_path ~loc)
+
+  let all_expanded xs ~f =
+    match
+      Result.List.fold_left xs ~init:[] ~f:(fun acc a ->
+          match f a with
+          | String_with_vars.Partial.Expanded a -> Ok (a :: acc)
+          | Unexpanded sw -> Error sw)
+    with
+    | Ok x -> String_with_vars.Partial.Expanded (List.rev x)
+    | Error sw -> Unexpanded sw
 
   let dep t expander = function
     | File s ->
-      let path = Expander.expand_path expander s in
-      let+ () = Build.path path in
-      [ path ]
+      Expander.Partial.expand_path expander s
+      |> String_with_vars.Partial.map ~f:(fun path ->
+             let+ () = Build.path path in
+             [ path ])
     | Alias s ->
-      let+ () = Build.alias (make_alias expander s) in
-      []
+      make_alias expander s
+      |> String_with_vars.Partial.map ~f:(fun a ->
+             let+ () = Build.alias a in
+             [])
     | Alias_rec s ->
-      let+ () =
-        Build_system.Alias.dep_rec ~loc:(String_with_vars.loc s)
-          (make_alias expander s)
-      in
-      []
+      make_alias expander s
+      |> String_with_vars.Partial.map ~f:(fun a ->
+             let+ () =
+               Build_system.Alias.dep_rec ~loc:(String_with_vars.loc s) a
+             in
+             [])
     | Glob_files s ->
       let loc = String_with_vars.loc s in
-      let path = Expander.expand_path expander s in
-      let pred = Glob.of_string_exn loc (Path.basename path) |> Glob.to_pred in
-      let dir = Path.parent_exn path in
-      Build.map ~f:Path.Set.to_list
-        (File_selector.create ~dir pred |> Build.paths_matching ~loc)
+      let path = Expander.Partial.expand_path expander s in
+      String_with_vars.Partial.map path ~f:(fun path ->
+          let pred =
+            Glob.of_string_exn loc (Path.basename path) |> Glob.to_pred
+          in
+          let dir = Path.parent_exn path in
+          Build.map ~f:Path.Set.to_list
+            (File_selector.create ~dir pred |> Build.paths_matching ~loc))
     | Source_tree s ->
-      let path = Expander.expand_path expander s in
-      Build.map ~f:Path.Set.to_list (Build.source_tree ~dir:path)
+      let path = Expander.Partial.expand_path expander s in
+      String_with_vars.Partial.map path ~f:(fun path ->
+          Build.map ~f:Path.Set.to_list (Build.source_tree ~dir:path))
     | Package p ->
-      let pkg = Package.Name.of_string (Expander.expand_str expander p) in
-      let+ () =
-        Build.alias (Build_system.Alias.package_install ~context:t.context ~pkg)
-      in
-      []
+      Expander.Partial.expand_str expander p
+      |> String_with_vars.Partial.map ~f:(fun pkg ->
+             let pkg = Package.Name.of_string pkg in
+             let+ () =
+               Build.alias
+                 (Build_system.Alias.package_install ~context:t.context ~pkg)
+             in
+             [])
     | Universe ->
-      let+ () = Build.dep Dep.universe in
-      []
+      String_with_vars.Partial.Expanded
+        (let+ () = Build.dep Dep.universe in
+         [])
     | Env_var var_sw ->
-      let var = Expander.expand_str expander var_sw in
-      let+ () = Build.env_var var in
-      []
+      Expander.Partial.expand_str expander var_sw
+      |> String_with_vars.Partial.map ~f:(fun var ->
+             let+ () = Build.env_var var in
+             [])
     | Sandbox_config sandbox_config ->
-      let+ () = Build.dep (Dep.sandbox_config sandbox_config) in
-      []
+      Expanded
+        (let+ () = Build.dep (Dep.sandbox_config sandbox_config) in
+         [])
 
   let make_interpreter ~f t ~expander l =
     let forms = Expander.Resolved_forms.empty () in
@@ -654,16 +679,31 @@ module Deps = struct
       Expander.with_record_no_ddeps expander forms ~dep_kind:Optional
         ~map_exe:Fn.id ~foreign_flags
     in
-    let+ deps =
-      Build.map ~f:List.concat (List.map l ~f:(f t expander) |> Build.all)
-    and+ () = Build.record_lib_deps (Expander.Resolved_forms.lib_deps forms)
-    and+ () = Build.path_set (Expander.Resolved_forms.sdeps forms) in
-    if Pform.Expansion.Map.is_empty (Expander.Resolved_forms.ddeps forms) then
-      deps
-    else
+    match
+      Pform.Expansion.Map.is_empty (Expander.Resolved_forms.ddeps forms)
+    with
+    | false ->
       (* calling [with_record_no_ddeps] above guarantees this never happens *)
       Code_error.raise "ddeps are not allowed in this position"
         [ ("forms", Dyn.Encoder.opaque forms) ]
+    | true ->
+      let deps =
+        match all_expanded l ~f:(f t expander) with
+        | Expanded deps -> Build.all deps
+        | Unexpanded sw ->
+          Build.fail
+            { fail =
+                (fun () ->
+                  let loc = String_with_vars.loc sw in
+                  User_error.raise ~loc
+                    [ Pp.text "failed to expand percent form" ])
+            }
+      in
+      (let+ deps = Build.map ~f:List.concat deps
+       and+ () = Build.record_lib_deps (Expander.Resolved_forms.lib_deps forms)
+       and+ () = Build.path_set (Expander.Resolved_forms.sdeps forms) in
+       deps)
+      |> Expander.Resolved_forms.prefix_failures forms
 
   let interpret t ~expander l =
     let+ _paths = make_interpreter ~f:dep t ~expander l in
@@ -673,11 +713,15 @@ module Deps = struct
     make_interpreter ~f:(fun t expander ->
       function
       | Bindings.Unnamed p ->
-        let+ l = dep t expander p in
-        List.map l ~f:(fun x -> Bindings.Unnamed x)
+        dep t expander p
+        |> String_with_vars.Partial.map ~f:(fun l ->
+               let+ l = l in
+               List.map l ~f:(fun x -> Bindings.Unnamed x))
       | Named (s, ps) ->
-        let+ l = Build.all (List.map ps ~f:(dep t expander)) in
-        [ Bindings.Named (s, List.concat l) ])
+        all_expanded ps ~f:(dep t expander)
+        |> String_with_vars.Partial.map ~f:(fun xs ->
+               let+ l = Build.all xs in
+               [ Bindings.Named (s, List.concat l) ]))
 end
 
 module Action = struct
@@ -775,9 +819,7 @@ module Action = struct
          (Action.Chdir (Path.build dir, action), deps))
     in
     Build.with_targets ~targets
-      ( match Expander.Resolved_forms.failures forms with
-      | [] -> build
-      | fail :: _ -> Build.fail fail >>> build )
+      (Expander.Resolved_forms.prefix_failures forms build)
 end
 
 let opaque t =

diff --git a/test/blackbox-tests/test-cases/bin-eager-deps/run.t b/test/blackbox-tests/test-cases/bin-eager-deps/run.t
@@ -16,9 +16,3 @@ when the rule needs to be used to build a target.
   >  (action (echo "test")))
   > EOF
   $ dune build @install --display short
-  File "dune", line 3, characters 9-32:
-  3 |  (deps %{bin:doesnotexistbinary})
-               ^^^^^^^^^^^^^^^^^^^^^^^
-  Error: Program doesnotexistbinary not found in the tree or in PATH
-   (context: default)
-  [1]