diff --git a/src/dune_lang/targets_spec.ml b/src/dune_lang/targets_spec.ml index 9e20f650a98..3495a98e3e5 100644 --- a/src/dune_lang/targets_spec.ml +++ b/src/dune_lang/targets_spec.ml @@ -33,16 +33,23 @@ module Kind = struct end module Static = struct - type 'path t = - { targets : ('path * Kind.t) list - ; multiplicity : Multiplicity.t - } + (* Change to take the full pair as path *) + type ('path, 'kind) named = { + name : string option; + path : 'path * 'kind; (* Now takes the tuple *) + } + + type 'path t = { + targets : ('path, Kind.t) named list; (* This now matches *) + multiplicity : Multiplicity.t; + } end type 'a t = | Static of 'a Static.t | Infer +(* Move decode_target before decode_named_target *) let decode_target ~allow_directory_targets = let open Dune_sexp.Decoder in let file = @@ -61,28 +68,71 @@ let decode_target ~allow_directory_targets = file <|> dir ;; -let decode_static ~allow_directory_targets = +let decode_named_target ~allow_directory_targets = let open Dune_sexp.Decoder in - let+ syntax_version = Dune_sexp.Syntax.get_exn Stanza.syntax - and+ targets = repeat (decode_target ~allow_directory_targets) in - if syntax_version < (1, 3) - then - List.iter targets ~f:(fun (target, (_ : Kind.t)) -> - if String_with_vars.has_pforms target - then - Dune_sexp.Syntax.Error.since - (String_with_vars.loc target) - Stanza.syntax - (1, 3) - ~what:"Using variables in the targets field"); - Static { targets; multiplicity = Multiple } + let named = + enter ( + let* loc = loc in + let* sexp_opt = peek in + match sexp_opt with + | Some (sexp : Dune_sexp.Ast.t) -> + (match sexp with + | Atom (loc, atom) when String.is_prefix (Dune_sexp.Atom.to_string atom) ~prefix:":" -> + let* () = junk in + let+ target = decode_target ~allow_directory_targets in + let atom_str = Dune_sexp.Atom.to_string atom in + let name = + match String.drop_prefix atom_str ~prefix:":" with + | Some name -> name + | None -> + User_error.raise ~loc [ Pp.text "Expected ':' prefix but couldn't extract name" ] + in + { Static.name = Some name; + path = target; (* target is already the (path, kind) tuple *) + } + | _ -> + let+ target = decode_target ~allow_directory_targets in + { Static.name = None; + path = target; (* target is already the (path, kind) tuple *) + }) + | None -> + let+ () = return () in + User_error.raise ~loc [ Pp.text "Expected an S-expression but got nothing" ] + ) + in + named + + let decode_static ~allow_directory_targets = + let open Dune_sexp.Decoder in + let+ syntax_version = Dune_sexp.Syntax.get_exn Stanza.syntax + and+ targets = repeat (decode_named_target ~allow_directory_targets) in + (* Check for variables in targets if using older syntax *) + if syntax_version < (1, 3) then + List.iter targets ~f:(fun target -> + let path = fst target.Static.path in (* Extract just the path from the tuple *) + if String_with_vars.has_pforms path then + Dune_sexp.Syntax.Error.since + (String_with_vars.loc path) + Stanza.syntax + (1, 3) + ~what:"Using variables in the targets field"); + + (* Check for duplicate names *) + let names = List.filter_map targets ~f:(fun t -> t.Static.name) in + if List.length names <> String.Set.cardinal (String.Set.of_list names) then + User_error.raise ~loc:(Loc.of_pos __POS__) [ Pp.text "Duplicate target names found" ]; + + Static { targets; multiplicity = Multiple } ;; let decode_one_static ~allow_directory_targets = let open Dune_sexp.Decoder in let+ () = Dune_sexp.Syntax.since Stanza.syntax (1, 11) - and+ target = decode_target ~allow_directory_targets in - Static { targets = [ target ]; multiplicity = One } + and+ target = decode_named_target ~allow_directory_targets in + Static { + targets = [ target ]; (* Directly use the target from decode_named_target *) + multiplicity = One + } ;; let field ~allow_directory_targets = @@ -92,4 +142,4 @@ let field ~allow_directory_targets = [ "target", decode_one_static ~allow_directory_targets ; "targets", decode_static ~allow_directory_targets ] -;; +;; \ No newline at end of file diff --git a/src/dune_lang/targets_spec.mli b/src/dune_lang/targets_spec.mli index c454586a2a7..93ec48688b2 100644 --- a/src/dune_lang/targets_spec.mli +++ b/src/dune_lang/targets_spec.mli @@ -17,10 +17,15 @@ module Kind : sig end module Static : sig - type 'path t = - { targets : ('path * Kind.t) list - ; multiplicity : Multiplicity.t - } + type ('path, 'kind) named = { + name : string option; + path : 'path * 'kind; (* Now takes the tuple *) + } + + type 'path t = { + targets : ('path, Kind.t) named list; (* This now matches *) + multiplicity : Multiplicity.t; + } end (** [Static] targets are listed by the user while [Infer] denotes that Dune must diff --git a/src/dune_pkg/fetch.ml b/src/dune_pkg/fetch.ml index a82517e7b66..f6690b21821 100644 --- a/src/dune_pkg/fetch.ml +++ b/src/dune_pkg/fetch.ml @@ -125,8 +125,10 @@ let label = "dune-fetch" let unpack_tarball ~target ~archive = Tar.extract ~archive ~target - >>| Result.map_error ~f:(fun () -> - Pp.textf "unable to extract %S" (Path.to_string archive)) + >>| Result.map_error ~f:(fun err -> + let stderr_output = Format.asprintf "%a" Error.pp err in + Pp.textf "unable to extract %S\nDetails: %s" (Path.to_string archive) stderr_output + ) ;; let check_checksum checksum path = diff --git a/src/dune_rules/action_unexpanded.ml b/src/dune_rules/action_unexpanded.ml index d0a742cfe4d..d4ff97bed9f 100644 --- a/src/dune_rules/action_unexpanded.ml +++ b/src/dune_rules/action_unexpanded.ml @@ -640,8 +640,9 @@ let expand (Expander.Deps.Without (Memo.return (Value.L.paths - (List.map targets ~f:(fun (target, (_ : Targets_spec.Kind.t)) -> - Path.build target)))))) + (List.map targets ~f:(fun named_target -> + let { Targets_spec.Static.path = (path_value, _kind); _ } = named_target in + Path.build path_value)))))) in Expander.set_expanding_what expander (User_action targets_written_by_user) in @@ -653,7 +654,8 @@ let expand | Infer -> targets | Static { targets = targets_written_by_user; multiplicity = _ } -> let files, dirs = - List.partition_map targets_written_by_user ~f:(fun (path, kind) -> + List.partition_map targets_written_by_user ~f:(fun named_target -> + let { Targets_spec.Static.path = (path, kind); _ } = named_target in validate_target_dir ~targets_dir ~loc targets path; match kind with | File -> Left path diff --git a/src/dune_rules/dir_status.ml b/src/dune_rules/dir_status.ml index c634e04f396..cc507aa80a4 100644 --- a/src/dune_rules/dir_status.ml +++ b/src/dune_rules/dir_status.ml @@ -109,12 +109,13 @@ let directory_targets_of_rule ~dir { Rule_conf.targets; loc = rule_loc; enabled_ Memo.return Path.Build.Map.empty | Static { targets; _ } -> let directory_targets = - List.fold_left targets ~init:Path.Build.Map.empty ~f:(fun acc (target, kind) -> + List.fold_left targets ~init:Path.Build.Map.empty ~f:(fun acc named_target -> + let { Targets_spec.Static.path = (string_with_vars, kind); _ } = named_target in match (kind : Targets_spec.Kind.t) with | File -> acc | Directory -> - let loc = String_with_vars.loc target in - (match String_with_vars.text_only target with + let loc = String_with_vars.loc string_with_vars in (* Changed target to string_with_vars *) + (match String_with_vars.text_only string_with_vars with (* Changed target to string_with_vars *) | None -> User_error.raise ~loc diff --git a/src/dune_rules/simple_rules.ml b/src/dune_rules/simple_rules.ml index 7159b3f1693..d29b4a57d12 100644 --- a/src/dune_rules/simple_rules.ml +++ b/src/dune_rules/simple_rules.ml @@ -88,17 +88,25 @@ let user_rule sctx ?extra_bindings ~dir ~expander (rule : Rule_conf.t) = match rule.targets with | Infer -> Memo.return Targets_spec.Infer | Static { targets; multiplicity } -> - let+ targets = - Memo.List.concat_map targets ~f:(fun (target, kind) -> + let+ paths_with_kinds = + Memo.List.concat_map targets ~f:(fun named_target -> + let (string_with_vars, kind) = named_target.Targets_spec.Static.path in (match multiplicity with | One -> - Expander.No_deps.expand expander ~mode:Single target >>| List.singleton - | Multiple -> Expander.No_deps.expand expander ~mode:Many target) + Expander.No_deps.expand expander ~mode:Single string_with_vars >>| List.singleton + | Multiple -> + Expander.No_deps.expand expander ~mode:Many string_with_vars) >>| - let error_loc = String_with_vars.loc target in + let error_loc = String_with_vars.loc string_with_vars in List.map ~f:(fun value -> check_filename ~kind ~dir ~error_loc value, kind)) in - Targets_spec.Static { multiplicity; targets } + Targets_spec.Static { + multiplicity; + targets = List.map paths_with_kinds ~f:(fun (path, kind) -> + { Targets_spec.Static.name = None; (* Preserve original name if needed *) + path = (path, kind); + } + )} in let expander = match extra_bindings with diff --git a/src/dune_rules/stanzas/rule_conf.ml b/src/dune_rules/stanzas/rule_conf.ml index 9cc9f8944af..d9951c571b1 100644 --- a/src/dune_rules/stanzas/rule_conf.ml +++ b/src/dune_rules/stanzas/rule_conf.ml @@ -6,21 +6,45 @@ module Mode = struct include Rule_mode_decoder end -type t = - { targets : String_with_vars.t Targets_spec.t - ; deps : Dep_conf.t Bindings.t - ; action : Loc.t * Dune_lang.Action.t - ; mode : Rule.Mode.t - ; locks : Locks.t - ; loc : Loc.t - ; enabled_if : Blang.t - ; aliases : Alias.Name.t list - ; package : Package.t option - } +module Targets_bindings = struct + type t = String_with_vars.t Bindings.t + + let decode : t Dune_lang.Decoder.t = + let+ bindings = Bindings.decode String_with_vars.decode in + let names = Bindings.var_names bindings in + let unique_names = String.Set.of_list names in + if List.length names <> String.Set.cardinal unique_names then + User_error.raise ~loc:(Loc.of_pos __POS__) + [Pp.text "Duplicate target names found"]; + bindings + + + let to_targets (bindings : t) : String_with_vars.t Targets_spec.t = + let targets = Bindings.to_list bindings in + Targets_spec.Static { + targets = List.map targets ~f:(fun path -> + { Targets_spec.Static.name = None; + path = (path, Targets_spec.Kind.File); + }); + multiplicity = Multiple + } + end + + +type t = { + targets : String_with_vars.t Targets_spec.t; + deps : Dep_conf.t Bindings.t; + action : Loc.t * Dune_lang.Action.t; + mode : Rule.Mode.t; + locks : Locks.t; + loc : Loc.t; + enabled_if : Blang.t; + aliases : Alias.Name.t list; + package : Package.t option; +} include Stanza.Make (struct type nonrec t = t - include Poly end) @@ -92,30 +116,31 @@ let directory_targets_extension = Dune_project.Extension.register syntax (Dune_lang.Decoder.return ((), [])) Dyn.unit ;; + let long_form = let* deps = field "deps" (Bindings.decode Dep_conf.decode) ~default:Bindings.empty in let* project = Dune_project.get_exn () in - let allow_directory_targets = + let _allow_directory_targets = Dune_project.is_extension_set project directory_targets_extension in String_with_vars.add_user_vars_to_decoding_env (Bindings.var_names deps) - (let+ loc = loc - and+ action_o = field_o "action" (located Dune_lang.Action.decode_dune_file) - and+ targets = Targets_spec.field ~allow_directory_targets - and+ locks = Locks.field () - and+ () = + (let* targets = + field "targets" ~default:(Targets_spec.Infer) + (Targets_bindings.decode >>| Targets_bindings.to_targets) + in + let* () = let+ fallback = field_b ~check: (Dune_lang.Syntax.renamed_in Stanza.syntax (1, 0) ~to_:"(mode fallback)") "fallback" in - (* The "fallback" field was only allowed in jbuild file, which we don't - support anymore. So this cannot be [true]. We just keep the parser - to provide a nice error message for people switching from jbuilder - to dune. *) assert (not fallback) + in + let+ loc = loc + and+ action_o = field_o "action" (located Dune_lang.Action.decode_dune_file) + and+ locks = Locks.field () and+ mode = Mode.field and+ enabled_if = Enabled_if.decode ~allowed_vars:Any ~since:(Some (1, 4)) () and+ package = @@ -198,28 +223,33 @@ let ocamllex_to_rule loc { modules; mode; enabled_if } = let src = name ^ ".mll" in let dst = name ^ ".ml" in { targets = - (* CR-someday aalekseyev: want to use [multiplicity = One] here, but - can't because this is might get parsed with old dune syntax where - [multiplicity = One] is not supported. *) - Static { targets = [ S.make_text loc dst, File ]; multiplicity = Multiple } - ; deps = Bindings.singleton (Dep_conf.File (S.virt_text __POS__ src)) - ; action = - ( loc - , Chdir - ( S.virt_pform __POS__ (Var Workspace_root) - , Dune_lang.Action.run + Static { + targets = [ + { + Targets_spec.Static.name = None; + path = (S.make_text loc dst, Targets_spec.Kind.File); + } + ]; + multiplicity = Multiple + }; + deps = Bindings.singleton (Dep_conf.File (S.virt_text __POS__ src)); + action = + ( loc, + Chdir + ( S.virt_pform __POS__ (Var Workspace_root), + Dune_lang.Action.run (S.virt_text __POS__ "ocamllex") - [ S.virt_text __POS__ "-q" - ; S.virt_text __POS__ "-o" - ; S.virt_pform __POS__ (Var Targets) - ; S.virt_pform __POS__ (Var Deps) - ] ) ) - ; mode - ; locks = [] - ; loc - ; enabled_if - ; aliases = [] - ; package = None + [ S.virt_text __POS__ "-q"; + S.virt_text __POS__ "-o"; + S.virt_pform __POS__ (Var Targets); + S.virt_pform __POS__ (Var Deps); + ] ) ); + mode; + locks = []; + loc; + enabled_if; + aliases = []; + package = None; }) ;; @@ -230,9 +260,13 @@ let ocamlyacc_to_rule loc { modules; mode; enabled_if } = { targets = Static { targets = - List.map - [ name ^ ".ml"; name ^ ".mli" ] - ~f:(fun target -> S.make_text loc target, Targets_spec.Kind.File) + List.map + [ name ^ ".ml"; name ^ ".mli" ] + ~f:(fun target -> + { Targets_spec.Static.name = None; + path = (S.make_text loc target, Targets_spec.Kind.File); + } + ) ; multiplicity = Multiple } ; deps = Bindings.singleton (Dep_conf.File (S.virt_text __POS__ src)) diff --git a/test/blackbox-tests/test-cases/workspaces/named-targets.t b/test/blackbox-tests/test-cases/workspaces/named-targets.t new file mode 100644 index 00000000000..a1458a372d0 --- /dev/null +++ b/test/blackbox-tests/test-cases/workspaces/named-targets.t @@ -0,0 +1,44 @@ +# Test for named targets in Dune rules + $ echo '(lang dune 3.8)' > dune-project + $ cat > dune << 'EOF' + > (rule + > (targets output.txt secondary.log) + > (action + > (progn + > (with-stdout-to output.txt (echo "This is the first target: %{target}")) + > (with-stdout-to secondary.log (echo "First target: %{target}, Named target: %{target:output.txt}")) + > ) + > ) + > ) + > EOF + $ dune build + $ test -f _build/default/output.txt + $ test -f _build/default/secondary.log + $ cat _build/default/output.txt + This is the first target: output.txt + $ cat _build/default/secondary.log + First target: output.txt, Named target: output.txt + +# Test for named targets with explicit naming + $ cat > dune << 'EOF' + > (rule + > (targets (:main output.txt) (:log secondary.log) third.data) + > (action + > (progn + > (with-stdout-to %{main} (echo "Main file, first target: %{target}, Log file: %{target:log}")) + > (with-stdout-to %{log} (echo "Log file, first target: %{target}, Main file: %{target:main}")) + > (with-stdout-to third.data (echo "Third file, Main: %{target:main}, Log: %{target:log}, First: %{target}")) + > ) + > ) + > ) + > EOF + $ dune build + $ test -f _build/default/output.txt + $ test -f _build/default/secondary.log + $ test -f _build/default/third.data + $ cat _build/default/output.txt + Main file, first target: output.txt, Log file: secondary.log + $ cat _build/default/secondary.log + Log file, first target: output.txt, Main file: output.txt + $ cat _build/default/third.data + Third file, Main: output.txt, Log: secondary.log, First: output.txt \ No newline at end of file