From 4be37dd140a48f8bde20490785448e9dc81457f9 Mon Sep 17 00:00:00 2001 From: Rudi Grinberg Date: Tue, 3 Jul 2018 23:41:56 +0700 Subject: [PATCH 01/34] Add a list constructor to Dep_conf.t Signed-off-by: Rudi Grinberg --- src/jbuild.ml | 40 ++++++++++++++++++++++++---------------- src/jbuild.mli | 1 + src/super_context.ml | 5 ++++- 3 files changed, 29 insertions(+), 17 deletions(-) diff --git a/src/jbuild.ml b/src/jbuild.ml index acfa7daf..2e03e39a 100644 --- a/src/jbuild.ml +++ b/src/jbuild.ml @@ -241,25 +241,30 @@ module Dep_conf = struct | Source_tree of String_with_vars.t | Package of String_with_vars.t | Universe + | List of t list let t = let t = let sw = String_with_vars.t in - sum - [ "file" , (sw >>| fun x -> File x) - ; "alias" , (sw >>| fun x -> Alias x) - ; "alias_rec" , (sw >>| fun x -> Alias_rec x) - ; "glob_files" , (sw >>| fun x -> Glob_files x) - ; "package" , (sw >>| fun x -> Package x) - ; "universe" , return Universe - ; "files_recursively_in", - (Syntax.renamed_in Stanza.syntax (1, 0) ~to_:"source_tree" - >>= fun () -> - sw >>| fun x -> Source_tree x) - ; "source_tree", - (Syntax.since Stanza.syntax (1, 0) >>= fun () -> - sw >>| fun x -> Source_tree x) - ] + fix (fun t -> + sum + [ "file" , (sw >>| fun x -> File x) + ; "alias" , (sw >>| fun x -> Alias x) + ; "alias_rec" , (sw >>| fun x -> Alias_rec x) + ; "glob_files" , (sw >>| fun x -> Glob_files x) + ; "package" , (sw >>| fun x -> Package x) + ; "universe" , return Universe + ; "files_recursively_in", + (Syntax.renamed_in Stanza.syntax (1, 0) ~to_:"source_tree" + >>= fun () -> + sw >>| fun x -> Source_tree x) + ; "source_tree", + (Syntax.since Stanza.syntax (1, 0) >>= fun () -> + sw >>| fun x -> Source_tree x) + ; "list", + (Syntax.since Stanza.syntax (1, 0) >>= fun () -> + (repeat t) >>| fun x -> List x) + ]) in peek_exn >>= function | Template _ | Atom _ | Quoted_string _ -> @@ -267,7 +272,7 @@ module Dep_conf = struct | List _ -> t open Sexp - let sexp_of_t = function + let rec sexp_of_t = function | File t -> List [Sexp.unsafe_atom_of_string "file" ; String_with_vars.sexp_of_t t] | Alias t -> @@ -286,6 +291,9 @@ module Dep_conf = struct String_with_vars.sexp_of_t t] | Universe -> Sexp.unsafe_atom_of_string "universe" + | List ts -> + List (Sexp.unsafe_atom_of_string "list" + :: (List.map ~f:sexp_of_t ts)) end module Preprocess = struct diff --git a/src/jbuild.mli b/src/jbuild.mli index f8493f7a..55c39671 100644 --- a/src/jbuild.mli +++ b/src/jbuild.mli @@ -90,6 +90,7 @@ module Dep_conf : sig | Source_tree of String_with_vars.t | Package of String_with_vars.t | Universe + | List of t list val t : t Sexp.Of_sexp.t val sexp_of_t : t -> Sexp.t diff --git a/src/super_context.ml b/src/super_context.ml index 1c8dd76f..9252a051 100644 --- a/src/super_context.ml +++ b/src/super_context.ml @@ -487,7 +487,7 @@ module Deps = struct let loc = String_with_vars.loc s in Alias.of_user_written_path ~loc ((expand_vars_path t ~scope ~dir s)) - let dep t ~scope ~dir = function + let rec dep t ~scope ~dir = function | File s -> let path = expand_vars_path t ~scope ~dir s in Build.path path @@ -521,6 +521,9 @@ module Deps = struct | Universe -> Build.path Build_system.universe_file >>^ fun () -> [] + | List ts -> + Build.all (List.map ~f:(dep t ~scope ~dir) ts) + >>^ List.concat let interpret t ~scope ~dir l = Build.all (List.map l ~f:(dep t ~scope ~dir)) From 93b0c618d10957a72ca9dd38b76e1b7b6f0aa9aa Mon Sep 17 00:00:00 2001 From: Rudi Grinberg Date: Wed, 4 Jul 2018 10:17:36 +0700 Subject: [PATCH 02/34] Add syntax for binding dependencies to names Signed-off-by: Rudi Grinberg --- src/jbuild.ml | 90 ++++++++++++------- src/jbuild.mli | 7 +- src/super_context.ml | 10 +-- test/blackbox-tests/dune.inc | 10 +++ test/blackbox-tests/test-cases/dep-vars/dune | 5 ++ .../test-cases/dep-vars/dune-project | 1 + test/blackbox-tests/test-cases/dep-vars/run.t | 3 + 7 files changed, 86 insertions(+), 40 deletions(-) create mode 100644 test/blackbox-tests/test-cases/dep-vars/dune create mode 100644 test/blackbox-tests/test-cases/dep-vars/dune-project create mode 100644 test/blackbox-tests/test-cases/dep-vars/run.t diff --git a/src/jbuild.ml b/src/jbuild.ml index 2e03e39a..a4ca5b48 100644 --- a/src/jbuild.ml +++ b/src/jbuild.ml @@ -233,7 +233,7 @@ module Pps_and_flags = struct end module Dep_conf = struct - type t = + type dep = | File of String_with_vars.t | Alias of String_with_vars.t | Alias_rec of String_with_vars.t @@ -241,38 +241,59 @@ module Dep_conf = struct | Source_tree of String_with_vars.t | Package of String_with_vars.t | Universe - | List of t list - let t = - let t = - let sw = String_with_vars.t in - fix (fun t -> - sum - [ "file" , (sw >>| fun x -> File x) - ; "alias" , (sw >>| fun x -> Alias x) - ; "alias_rec" , (sw >>| fun x -> Alias_rec x) - ; "glob_files" , (sw >>| fun x -> Glob_files x) - ; "package" , (sw >>| fun x -> Package x) - ; "universe" , return Universe - ; "files_recursively_in", - (Syntax.renamed_in Stanza.syntax (1, 0) ~to_:"source_tree" - >>= fun () -> - sw >>| fun x -> Source_tree x) - ; "source_tree", - (Syntax.since Stanza.syntax (1, 0) >>= fun () -> - sw >>| fun x -> Source_tree x) - ; "list", - (Syntax.since Stanza.syntax (1, 0) >>= fun () -> - (repeat t) >>| fun x -> List x) - ]) - in + type t = + | Unnamed of dep list + | Named of string * dep list + + let dep_cons = + let sw = String_with_vars.t in + [ "file" , (sw >>| fun x -> File x) + ; "alias" , (sw >>| fun x -> Alias x) + ; "alias_rec" , (sw >>| fun x -> Alias_rec x) + ; "glob_files" , (sw >>| fun x -> Glob_files x) + ; "package" , (sw >>| fun x -> Package x) + ; "universe" , return Universe + ; "files_recursively_in", + (Syntax.renamed_in Stanza.syntax (1, 0) ~to_:"source_tree" + >>= fun () -> + sw >>| fun x -> Source_tree x) + ; "source_tree", + (Syntax.since Stanza.syntax (1, 0) >>= fun () -> + sw >>| fun x -> Source_tree x) + ] + + let make_dep_parser ~single ~many = peek_exn >>= function | Template _ | Atom _ | Quoted_string _ -> - String_with_vars.t >>| fun x -> File x - | List _ -> t + String_with_vars.t >>| fun x -> single (File x) + | List _ -> many + + let dep = + let dep = + let dep_no_list = + make_dep_parser ~single:(fun x -> x) ~many:(sum dep_cons) in + sum (("list", repeat dep_no_list) + :: (List.map dep_cons ~f:(fun (n, d) -> (n, d >>| List.singleton)))) + in + make_dep_parser ~single:List.singleton ~many:dep + + let t = + peek_exn >>= function + | Atom (loc, A s) when String.length s > 1 && s.[0] = ':' -> + begin + string >>= fun name -> + peek >>= function + | None -> of_sexp_errorf loc "Naked binding %s" s + | Some _ -> dep + >>| fun deps -> + Named (name, deps) + end + | _ -> + dep >>| fun dep -> Unnamed dep open Sexp - let rec sexp_of_t = function + let sexp_of_dep = function | File t -> List [Sexp.unsafe_atom_of_string "file" ; String_with_vars.sexp_of_t t] | Alias t -> @@ -291,9 +312,12 @@ module Dep_conf = struct String_with_vars.sexp_of_t t] | Universe -> Sexp.unsafe_atom_of_string "universe" - | List ts -> - List (Sexp.unsafe_atom_of_string "list" - :: (List.map ~f:sexp_of_t ts)) + + let sexp_of_t = + let open Sexp.To_sexp in + function + | Unnamed dep -> (list sexp_of_dep) dep + | Named (name, dep) -> List [Sexp.atom name; (list sexp_of_dep) dep] end module Preprocess = struct @@ -1239,7 +1263,7 @@ module Rule = struct let src = name ^ ".mll" in let dst = name ^ ".ml" in { targets = Static [dst] - ; deps = [File (S.virt_text __POS__ src)] + ; deps = [Unnamed [File (S.virt_text __POS__ src)]] ; action = (loc, Chdir @@ -1260,7 +1284,7 @@ module Rule = struct List.map modules ~f:(fun name -> let src = name ^ ".mly" in { targets = Static [name ^ ".ml"; name ^ ".mli"] - ; deps = [File (S.virt_text __POS__ src)] + ; deps = [Unnamed [File (S.virt_text __POS__ src)]] ; action = (loc, Chdir diff --git a/src/jbuild.mli b/src/jbuild.mli index 55c39671..b6ab651c 100644 --- a/src/jbuild.mli +++ b/src/jbuild.mli @@ -82,7 +82,7 @@ module Lib_deps : sig end module Dep_conf : sig - type t = + type dep = | File of String_with_vars.t | Alias of String_with_vars.t | Alias_rec of String_with_vars.t @@ -90,7 +90,10 @@ module Dep_conf : sig | Source_tree of String_with_vars.t | Package of String_with_vars.t | Universe - | List of t list + + type t = + | Unnamed of dep list + | Named of string * dep list val t : t Sexp.Of_sexp.t val sexp_of_t : t -> Sexp.t diff --git a/src/super_context.ml b/src/super_context.ml index 9252a051..040f7fe4 100644 --- a/src/super_context.ml +++ b/src/super_context.ml @@ -487,7 +487,7 @@ module Deps = struct let loc = String_with_vars.loc s in Alias.of_user_written_path ~loc ((expand_vars_path t ~scope ~dir s)) - let rec dep t ~scope ~dir = function + let dep t ~scope ~dir = function | File s -> let path = expand_vars_path t ~scope ~dir s in Build.path path @@ -521,12 +521,12 @@ module Deps = struct | Universe -> Build.path Build_system.universe_file >>^ fun () -> [] - | List ts -> - Build.all (List.map ~f:(dep t ~scope ~dir) ts) - >>^ List.concat let interpret t ~scope ~dir l = - Build.all (List.map l ~f:(dep t ~scope ~dir)) + List.concat_map l ~f:(function + | Unnamed d + | Named (_, d) -> List.map ~f:(dep t ~scope ~dir) d) + |> Build.all >>^ List.concat end diff --git a/test/blackbox-tests/dune.inc b/test/blackbox-tests/dune.inc index 555a7d2f..72e2921f 100644 --- a/test/blackbox-tests/dune.inc +++ b/test/blackbox-tests/dune.inc @@ -80,6 +80,14 @@ test-cases/custom-build-dir (progn (run %{exe:cram.exe} -test run.t) (diff? run.t run.t.corrected))))) +(alias + (name dep-vars) + (deps (package dune) (source_tree test-cases/dep-vars)) + (action + (chdir + test-cases/dep-vars + (progn (run %{exe:cram.exe} -test run.t) (diff? run.t run.t.corrected))))) + (alias (name depend-on-the-universe) (deps (package dune) (source_tree test-cases/depend-on-the-universe)) @@ -680,6 +688,7 @@ (alias copy_files) (alias cross-compilation) (alias custom-build-dir) + (alias dep-vars) (alias depend-on-the-universe) (alias dune-jbuild-var-case) (alias dune-ppx-driver-system) @@ -762,6 +771,7 @@ (alias copy_files) (alias cross-compilation) (alias custom-build-dir) + (alias dep-vars) (alias depend-on-the-universe) (alias dune-jbuild-var-case) (alias dune-ppx-driver-system) diff --git a/test/blackbox-tests/test-cases/dep-vars/dune b/test/blackbox-tests/test-cases/dep-vars/dune new file mode 100644 index 00000000..cd26888c --- /dev/null +++ b/test/blackbox-tests/test-cases/dep-vars/dune @@ -0,0 +1,5 @@ + +(rule + (deps :foo (list a b) :baz foo (list (alias test)) (list a b c)) + (targets bar) + (action (with-stdout-to bar (echo "foo")))) diff --git a/test/blackbox-tests/test-cases/dep-vars/dune-project b/test/blackbox-tests/test-cases/dep-vars/dune-project new file mode 100644 index 00000000..b2559fa0 --- /dev/null +++ b/test/blackbox-tests/test-cases/dep-vars/dune-project @@ -0,0 +1 @@ +(lang dune 1.0) \ No newline at end of file diff --git a/test/blackbox-tests/test-cases/dep-vars/run.t b/test/blackbox-tests/test-cases/dep-vars/run.t new file mode 100644 index 00000000..0d2bd1b0 --- /dev/null +++ b/test/blackbox-tests/test-cases/dep-vars/run.t @@ -0,0 +1,3 @@ +Dependencies are allowed :patterns + + $ dune build From aab701d4a19a62f4899bcf1e5df88691b992bd42 Mon Sep 17 00:00:00 2001 From: Rudi Grinberg Date: Wed, 4 Jul 2018 14:40:12 +0700 Subject: [PATCH 03/34] Add error checking for duplicate bindings Signed-off-by: Rudi Grinberg --- src/gen_rules.ml | 6 +-- src/jbuild.ml | 103 ++++++++++++++++++++++++++---------------- src/jbuild.mli | 16 ++++--- src/super_context.ml | 11 +++-- src/super_context.mli | 7 +++ 5 files changed, 93 insertions(+), 50 deletions(-) diff --git a/src/gen_rules.ml b/src/gen_rules.ml index eee6291e..bbf7d990 100644 --- a/src/gen_rules.ml +++ b/src/gen_rules.ml @@ -187,7 +187,7 @@ module Gen(P : Install_rules.Params) = struct in SC.add_rule_get_targets sctx ~mode:rule.mode ~loc:rule.loc ~locks:(interpret_locks ~dir ~scope rule.locks) - (SC.Deps.interpret sctx ~scope ~dir rule.deps + (SC.Deps.interpret_bindings sctx ~scope ~dir rule.deps >>> SC.Action.run sctx @@ -929,7 +929,7 @@ module Gen(P : Install_rules.Params) = struct let module S = Sexp.To_sexp in Sexp.List [ Sexp.unsafe_atom_of_string "user-alias" - ; S.list Jbuild.Dep_conf.sexp_of_t alias_conf.deps + ; Jbuild.Dep_conf.sexp_of_bindings alias_conf.deps ; S.option Action.Unexpanded.sexp_of_t (Option.map alias_conf.action ~f:snd) ] @@ -939,7 +939,7 @@ module Gen(P : Install_rules.Params) = struct ~name:alias_conf.name ~stamp ~locks:(interpret_locks ~dir ~scope alias_conf.locks) - (SC.Deps.interpret sctx ~scope ~dir alias_conf.deps + (SC.Deps.interpret_bindings sctx ~scope ~dir alias_conf.deps >>> match alias_conf.action with | None -> Build.progn [] diff --git a/src/jbuild.ml b/src/jbuild.ml index a4ca5b48..0ed88f39 100644 --- a/src/jbuild.ml +++ b/src/jbuild.ml @@ -233,7 +233,7 @@ module Pps_and_flags = struct end module Dep_conf = struct - type dep = + type t = | File of String_with_vars.t | Alias of String_with_vars.t | Alias_rec of String_with_vars.t @@ -242,9 +242,15 @@ module Dep_conf = struct | Package of String_with_vars.t | Universe - type t = - | Unnamed of dep list - | Named of string * dep list + type bindings = + { named : (Loc.t * t list) String.Map.t + ; unnamed : t list + } + + let empty_bindings = + { named = String.Map.empty + ; unnamed = [] + } let dep_cons = let sw = String_with_vars.t in @@ -269,31 +275,43 @@ module Dep_conf = struct String_with_vars.t >>| fun x -> single (File x) | List _ -> many - let dep = - let dep = - let dep_no_list = - make_dep_parser ~single:(fun x -> x) ~many:(sum dep_cons) in - sum (("list", repeat dep_no_list) - :: (List.map dep_cons ~f:(fun (n, d) -> (n, d >>| List.singleton)))) - in - make_dep_parser ~single:List.singleton ~many:dep - let t = - peek_exn >>= function - | Atom (loc, A s) when String.length s > 1 && s.[0] = ':' -> - begin - string >>= fun name -> - peek >>= function - | None -> of_sexp_errorf loc "Naked binding %s" s - | Some _ -> dep - >>| fun deps -> - Named (name, deps) - end - | _ -> - dep >>| fun dep -> Unnamed dep + make_dep_parser ~single:(fun x -> x) ~many:(sum dep_cons) + + let bindings = + let dep = + make_dep_parser ~single:List.singleton ~many:( + ("list", repeat t) + :: List.map dep_cons ~f:(fun (n, d) -> (n, d >>| List.singleton)) + |> sum) + in + let binding = + peek_exn >>= function + | Atom (loc, A s) when String.length s > 1 && s.[0] = ':' -> + begin + string >>= fun name -> + peek >>= function + | None -> of_sexp_errorf loc "Naked binding %s" s + | Some _ -> dep + >>| fun deps -> + Left (name, (loc, deps)) + end + | _ -> + dep >>| fun dep -> Right dep + in + list binding >>| (fun bindings -> + let (named, unnamed) = List.partition_map bindings ~f:(fun x -> x) in + { unnamed = List.flatten unnamed + ; named = + match String.Map.of_list named with + | Ok x -> x + | Error (name, (l1, _), (l2, _)) -> + of_sexp_errorf l1 "Variable %s is already defined in %s" + name (Loc.to_file_colon_line l2) + }) open Sexp - let sexp_of_dep = function + let sexp_of_t = function | File t -> List [Sexp.unsafe_atom_of_string "file" ; String_with_vars.sexp_of_t t] | Alias t -> @@ -313,11 +331,13 @@ module Dep_conf = struct | Universe -> Sexp.unsafe_atom_of_string "universe" - let sexp_of_t = - let open Sexp.To_sexp in - function - | Unnamed dep -> (list sexp_of_dep) dep - | Named (name, dep) -> List [Sexp.atom name; (list sexp_of_dep) dep] + let sexp_of_bindings { unnamed; named } = + let unnamed = List.map ~f:sexp_of_t unnamed in + let named = + String.Map.foldi ~init:[] named ~f:(fun n (_, d) acc -> + Sexp.unsafe_atom_of_string (":" ^ n) :: (List.map ~f:sexp_of_t d) @ acc) + in + List (unnamed @ named) end module Preprocess = struct @@ -1103,7 +1123,7 @@ module Rule = struct type t = { targets : Targets.t - ; deps : Dep_conf.t list + ; deps : Dep_conf.bindings ; action : Loc.t * Action.Unexpanded.t ; mode : Mode.t ; locks : String_with_vars.t list @@ -1145,7 +1165,7 @@ module Rule = struct let short_form = located Action.Unexpanded.t >>| fun (loc, action) -> { targets = Infer - ; deps = [] + ; deps = Dep_conf.empty_bindings ; action = (loc, action) ; mode = Standard ; locks = [] @@ -1158,7 +1178,8 @@ module Rule = struct >>= fun action -> field "targets" (list file_in_current_dir) >>= fun targets -> - field "deps" (list Dep_conf.t) ~default:[] >>= fun deps -> + field "deps" (Dep_conf.bindings) ~default:Dep_conf.empty_bindings + >>= fun deps -> field "locks" (list String_with_vars.t) ~default:[] >>= fun locks -> map_validate (field_b @@ -1263,7 +1284,9 @@ module Rule = struct let src = name ^ ".mll" in let dst = name ^ ".ml" in { targets = Static [dst] - ; deps = [Unnamed [File (S.virt_text __POS__ src)]] + ; deps = { Dep_conf.empty_bindings with + unnamed = [File (S.virt_text __POS__ src)] + } ; action = (loc, Chdir @@ -1284,7 +1307,10 @@ module Rule = struct List.map modules ~f:(fun name -> let src = name ^ ".mly" in { targets = Static [name ^ ".ml"; name ^ ".mli"] - ; deps = [Unnamed [File (S.virt_text __POS__ src)]] + ; deps = + { Dep_conf.empty_bindings with + unnamed = [File (S.virt_text __POS__ src)] + } ; action = (loc, Chdir @@ -1352,7 +1378,7 @@ end module Alias_conf = struct type t = { name : string - ; deps : Dep_conf.t list + ; deps : Dep_conf.bindings ; action : (Loc.t * Action.Unexpanded.t) option ; locks : String_with_vars.t list ; package : Package.t option @@ -1368,10 +1394,11 @@ module Alias_conf = struct let t = record (field "name" alias_name >>= fun name -> - field "deps" (list Dep_conf.t) ~default:[] >>= fun deps -> field_o "package" Pkg.t >>= fun package -> field_o "action" (located Action.Unexpanded.t) >>= fun action -> field "locks" (list String_with_vars.t) ~default:[] >>= fun locks -> + field "deps" Dep_conf.bindings ~default:Dep_conf.empty_bindings + >>= fun deps -> return { name ; deps diff --git a/src/jbuild.mli b/src/jbuild.mli index b6ab651c..6afc35a9 100644 --- a/src/jbuild.mli +++ b/src/jbuild.mli @@ -82,7 +82,7 @@ module Lib_deps : sig end module Dep_conf : sig - type dep = + type t = | File of String_with_vars.t | Alias of String_with_vars.t | Alias_rec of String_with_vars.t @@ -91,12 +91,16 @@ module Dep_conf : sig | Package of String_with_vars.t | Universe - type t = - | Unnamed of dep list - | Named of string * dep list + type bindings = + { named: (Loc.t * t list) String.Map.t + ; unnamed : t list + } + + val bindings : bindings Sexp.Of_sexp.t val t : t Sexp.Of_sexp.t val sexp_of_t : t -> Sexp.t + val sexp_of_bindings : bindings -> Sexp.t end module Buildable : sig @@ -288,7 +292,7 @@ module Rule : sig type t = { targets : Targets.t - ; deps : Dep_conf.t list + ; deps : Dep_conf.bindings ; action : Loc.t * Action.Unexpanded.t ; mode : Mode.t ; locks : String_with_vars.t list @@ -311,7 +315,7 @@ end module Alias_conf : sig type t = { name : string - ; deps : Dep_conf.t list + ; deps : Dep_conf.bindings ; action : (Loc.t * Action.Unexpanded.t) option ; locks : String_with_vars.t list ; package : Package.t option diff --git a/src/super_context.ml b/src/super_context.ml index 040f7fe4..c2561b18 100644 --- a/src/super_context.ml +++ b/src/super_context.ml @@ -523,9 +523,14 @@ module Deps = struct >>^ fun () -> [] let interpret t ~scope ~dir l = - List.concat_map l ~f:(function - | Unnamed d - | Named (_, d) -> List.map ~f:(dep t ~scope ~dir) d) + List.map l ~f:(dep t ~scope ~dir) + |> Build.all + >>^ List.concat + + let interpret_bindings t ~scope ~dir { unnamed; named } = + String.Map.fold ~init:unnamed named ~f:(fun (_, ds) acc -> + List.rev_append ds acc) + |> List.map ~f:(dep t ~scope ~dir) |> Build.all >>^ List.concat end diff --git a/src/super_context.mli b/src/super_context.mli index 54dbe470..8d668d18 100644 --- a/src/super_context.mli +++ b/src/super_context.mli @@ -219,6 +219,13 @@ module Deps : sig -> dir:Path.t -> Dep_conf.t list -> (unit, Path.t list) Build.t + + val interpret_bindings + : t + -> scope:Scope.t + -> dir:Path.t + -> Dep_conf.bindings + -> (unit, Path.t list) Build.t end (** Interpret action written in jbuild files *) From b9be63f4b7eb988a35ecc41d6bdc6a7a9dce4435 Mon Sep 17 00:00:00 2001 From: Rudi Grinberg Date: Wed, 4 Jul 2018 18:43:37 +0700 Subject: [PATCH 04/34] small simplification Signed-off-by: Rudi Grinberg --- src/action.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/action.ml b/src/action.ml index 6a7f86dc..58802cac 100644 --- a/src/action.ml +++ b/src/action.ml @@ -525,7 +525,7 @@ module Unexpanded = struct Redirect (outputs, E.path ~dir ~f fn, partial_expand t ~dir ~map_exe ~f) | Ignore (outputs, t) -> Ignore (outputs, partial_expand t ~dir ~map_exe ~f) - | Progn l -> Progn (List.map l ~f:(fun t -> partial_expand t ~dir ~map_exe ~f)) + | Progn l -> Progn (List.map l ~f:(partial_expand ~dir ~map_exe ~f)) | Echo xs -> Echo (List.map xs ~f:(E.cat_strings ~dir ~f)) | Cat x -> Cat (E.path ~dir ~f x) | Copy (x, y) -> From f121a1546e87c092581f7c5989c9b2541a0e52f0 Mon Sep 17 00:00:00 2001 From: Rudi Grinberg Date: Thu, 5 Jul 2018 23:33:51 +0700 Subject: [PATCH 05/34] Generalize named bindings to Jbuild.Named.t Signed-off-by: Rudi Grinberg --- src/gen_rules.ml | 6 +-- src/jbuild.ml | 103 ++++++++++++++++++++++-------------------- src/jbuild.mli | 21 +++++---- src/super_context.ml | 2 +- src/super_context.mli | 4 +- 5 files changed, 71 insertions(+), 65 deletions(-) diff --git a/src/gen_rules.ml b/src/gen_rules.ml index bbf7d990..b853de4e 100644 --- a/src/gen_rules.ml +++ b/src/gen_rules.ml @@ -187,7 +187,7 @@ module Gen(P : Install_rules.Params) = struct in SC.add_rule_get_targets sctx ~mode:rule.mode ~loc:rule.loc ~locks:(interpret_locks ~dir ~scope rule.locks) - (SC.Deps.interpret_bindings sctx ~scope ~dir rule.deps + (SC.Deps.interpret_named sctx ~scope ~dir rule.deps >>> SC.Action.run sctx @@ -929,7 +929,7 @@ module Gen(P : Install_rules.Params) = struct let module S = Sexp.To_sexp in Sexp.List [ Sexp.unsafe_atom_of_string "user-alias" - ; Jbuild.Dep_conf.sexp_of_bindings alias_conf.deps + ; Jbuild.Named.sexp_of_t Jbuild.Dep_conf.sexp_of_t alias_conf.deps ; S.option Action.Unexpanded.sexp_of_t (Option.map alias_conf.action ~f:snd) ] @@ -939,7 +939,7 @@ module Gen(P : Install_rules.Params) = struct ~name:alias_conf.name ~stamp ~locks:(interpret_locks ~dir ~scope alias_conf.locks) - (SC.Deps.interpret_bindings sctx ~scope ~dir alias_conf.deps + (SC.Deps.interpret_named sctx ~scope ~dir alias_conf.deps >>> match alias_conf.action with | None -> Build.progn [] diff --git a/src/jbuild.ml b/src/jbuild.ml index 0ed88f39..ddaaf303 100644 --- a/src/jbuild.ml +++ b/src/jbuild.ml @@ -232,6 +232,52 @@ module Pps_and_flags = struct Dune_syntax.t end +module Named = struct + type 'a t = + { named: (Loc.t * 'a list) String.Map.t + ; unnamed : 'a list + } + + let empty = + { named = String.Map.empty + ; unnamed = [] + } + + let t elem = + let binding = + peek_exn >>= function + | Atom (loc, A s) when String.length s > 1 && s.[0] = ':' -> + begin + string >>= fun name -> + peek >>= function + | None -> of_sexp_errorf loc "Naked binding %s" s + | Some _ -> + elem >>| fun elem -> + Left (name, (loc, elem)) + end + | _ -> + elem >>| fun elem -> Right elem + in + list binding >>| (fun bindings -> + let (named, unnamed) = List.partition_map bindings ~f:(fun x -> x) in + { unnamed = List.flatten unnamed + ; named = + match String.Map.of_list named with + | Ok x -> x + | Error (name, (l1, _), (l2, _)) -> + of_sexp_errorf l1 "Variable %s is already defined in %s" + name (Loc.to_file_colon_line l2) + }) + + let sexp_of_t sexp_of_a { unnamed; named } = + let unnamed = List.map ~f:sexp_of_a unnamed in + let named = + String.Map.foldi ~init:[] named ~f:(fun n (_, d) acc -> + Sexp.unsafe_atom_of_string (":" ^ n) :: (List.map ~f:sexp_of_a d) @ acc) + in + Sexp.List (unnamed @ named) +end + module Dep_conf = struct type t = | File of String_with_vars.t @@ -242,16 +288,6 @@ module Dep_conf = struct | Package of String_with_vars.t | Universe - type bindings = - { named : (Loc.t * t list) String.Map.t - ; unnamed : t list - } - - let empty_bindings = - { named = String.Map.empty - ; unnamed = [] - } - let dep_cons = let sw = String_with_vars.t in [ "file" , (sw >>| fun x -> File x) @@ -285,30 +321,7 @@ module Dep_conf = struct :: List.map dep_cons ~f:(fun (n, d) -> (n, d >>| List.singleton)) |> sum) in - let binding = - peek_exn >>= function - | Atom (loc, A s) when String.length s > 1 && s.[0] = ':' -> - begin - string >>= fun name -> - peek >>= function - | None -> of_sexp_errorf loc "Naked binding %s" s - | Some _ -> dep - >>| fun deps -> - Left (name, (loc, deps)) - end - | _ -> - dep >>| fun dep -> Right dep - in - list binding >>| (fun bindings -> - let (named, unnamed) = List.partition_map bindings ~f:(fun x -> x) in - { unnamed = List.flatten unnamed - ; named = - match String.Map.of_list named with - | Ok x -> x - | Error (name, (l1, _), (l2, _)) -> - of_sexp_errorf l1 "Variable %s is already defined in %s" - name (Loc.to_file_colon_line l2) - }) + Named.t dep open Sexp let sexp_of_t = function @@ -330,14 +343,6 @@ module Dep_conf = struct String_with_vars.sexp_of_t t] | Universe -> Sexp.unsafe_atom_of_string "universe" - - let sexp_of_bindings { unnamed; named } = - let unnamed = List.map ~f:sexp_of_t unnamed in - let named = - String.Map.foldi ~init:[] named ~f:(fun n (_, d) acc -> - Sexp.unsafe_atom_of_string (":" ^ n) :: (List.map ~f:sexp_of_t d) @ acc) - in - List (unnamed @ named) end module Preprocess = struct @@ -1123,7 +1128,7 @@ module Rule = struct type t = { targets : Targets.t - ; deps : Dep_conf.bindings + ; deps : Dep_conf.t Named.t ; action : Loc.t * Action.Unexpanded.t ; mode : Mode.t ; locks : String_with_vars.t list @@ -1165,7 +1170,7 @@ module Rule = struct let short_form = located Action.Unexpanded.t >>| fun (loc, action) -> { targets = Infer - ; deps = Dep_conf.empty_bindings + ; deps = Named.empty ; action = (loc, action) ; mode = Standard ; locks = [] @@ -1178,7 +1183,7 @@ module Rule = struct >>= fun action -> field "targets" (list file_in_current_dir) >>= fun targets -> - field "deps" (Dep_conf.bindings) ~default:Dep_conf.empty_bindings + field "deps" Dep_conf.bindings ~default:Named.empty >>= fun deps -> field "locks" (list String_with_vars.t) ~default:[] >>= fun locks -> map_validate @@ -1284,7 +1289,7 @@ module Rule = struct let src = name ^ ".mll" in let dst = name ^ ".ml" in { targets = Static [dst] - ; deps = { Dep_conf.empty_bindings with + ; deps = { Named.empty with unnamed = [File (S.virt_text __POS__ src)] } ; action = @@ -1308,7 +1313,7 @@ module Rule = struct let src = name ^ ".mly" in { targets = Static [name ^ ".ml"; name ^ ".mli"] ; deps = - { Dep_conf.empty_bindings with + { Named.empty with unnamed = [File (S.virt_text __POS__ src)] } ; action = @@ -1378,7 +1383,7 @@ end module Alias_conf = struct type t = { name : string - ; deps : Dep_conf.bindings + ; deps : Dep_conf.t Named.t ; action : (Loc.t * Action.Unexpanded.t) option ; locks : String_with_vars.t list ; package : Package.t option @@ -1397,7 +1402,7 @@ module Alias_conf = struct field_o "package" Pkg.t >>= fun package -> field_o "action" (located Action.Unexpanded.t) >>= fun action -> field "locks" (list String_with_vars.t) ~default:[] >>= fun locks -> - field "deps" Dep_conf.bindings ~default:Dep_conf.empty_bindings + field "deps" Dep_conf.bindings ~default:Named.empty >>= fun deps -> return { name diff --git a/src/jbuild.mli b/src/jbuild.mli index 6afc35a9..50b394e8 100644 --- a/src/jbuild.mli +++ b/src/jbuild.mli @@ -81,6 +81,15 @@ module Lib_deps : sig val of_pps : Pp.t list -> t end +module Named : sig + type 'a t = + { named : (Loc.t * 'a list) String.Map.t + ; unnamed : 'a list + } + + val sexp_of_t : ('a -> Usexp.t) -> 'a t -> Usexp.t +end + module Dep_conf : sig type t = | File of String_with_vars.t @@ -91,16 +100,8 @@ module Dep_conf : sig | Package of String_with_vars.t | Universe - type bindings = - { named: (Loc.t * t list) String.Map.t - ; unnamed : t list - } - - val bindings : bindings Sexp.Of_sexp.t - val t : t Sexp.Of_sexp.t val sexp_of_t : t -> Sexp.t - val sexp_of_bindings : bindings -> Sexp.t end module Buildable : sig @@ -292,7 +293,7 @@ module Rule : sig type t = { targets : Targets.t - ; deps : Dep_conf.bindings + ; deps : Dep_conf.t Named.t ; action : Loc.t * Action.Unexpanded.t ; mode : Mode.t ; locks : String_with_vars.t list @@ -315,7 +316,7 @@ end module Alias_conf : sig type t = { name : string - ; deps : Dep_conf.bindings + ; deps : Dep_conf.t Named.t ; action : (Loc.t * Action.Unexpanded.t) option ; locks : String_with_vars.t list ; package : Package.t option diff --git a/src/super_context.ml b/src/super_context.ml index c2561b18..7393410f 100644 --- a/src/super_context.ml +++ b/src/super_context.ml @@ -527,7 +527,7 @@ module Deps = struct |> Build.all >>^ List.concat - let interpret_bindings t ~scope ~dir { unnamed; named } = + let interpret_named t ~scope ~dir { Named.unnamed; named } = String.Map.fold ~init:unnamed named ~f:(fun (_, ds) acc -> List.rev_append ds acc) |> List.map ~f:(dep t ~scope ~dir) diff --git a/src/super_context.mli b/src/super_context.mli index 8d668d18..eb86dd28 100644 --- a/src/super_context.mli +++ b/src/super_context.mli @@ -220,11 +220,11 @@ module Deps : sig -> Dep_conf.t list -> (unit, Path.t list) Build.t - val interpret_bindings + val interpret_named : t -> scope:Scope.t -> dir:Path.t - -> Dep_conf.bindings + -> Dep_conf.t Named.t -> (unit, Path.t list) Build.t end From 7fbe0bc172eae2964837648ac336c2041185c86b Mon Sep 17 00:00:00 2001 From: Rudi Grinberg Date: Thu, 5 Jul 2018 23:36:04 +0700 Subject: [PATCH 06/34] Formatting tweaks Signed-off-by: Rudi Grinberg --- src/jbuild.ml | 22 ++++++++++++---------- 1 file changed, 12 insertions(+), 10 deletions(-) diff --git a/src/jbuild.ml b/src/jbuild.ml index ddaaf303..00033933 100644 --- a/src/jbuild.ml +++ b/src/jbuild.ml @@ -326,21 +326,23 @@ module Dep_conf = struct open Sexp let sexp_of_t = function | File t -> - List [Sexp.unsafe_atom_of_string "file" ; String_with_vars.sexp_of_t t] + List [ Sexp.unsafe_atom_of_string "file" + ; String_with_vars.sexp_of_t t ] | Alias t -> - List [Sexp.unsafe_atom_of_string "alias" ; String_with_vars.sexp_of_t t] + List [ Sexp.unsafe_atom_of_string "alias" + ; String_with_vars.sexp_of_t t ] | Alias_rec t -> - List [Sexp.unsafe_atom_of_string "alias_rec" ; - String_with_vars.sexp_of_t t] + List [ Sexp.unsafe_atom_of_string "alias_rec" + ; String_with_vars.sexp_of_t t ] | Glob_files t -> - List [Sexp.unsafe_atom_of_string "glob_files" ; - String_with_vars.sexp_of_t t] + List [ Sexp.unsafe_atom_of_string "glob_files" + ; String_with_vars.sexp_of_t t ] | Source_tree t -> - List [Sexp.unsafe_atom_of_string "files_recursively_in" ; - String_with_vars.sexp_of_t t] + List [ Sexp.unsafe_atom_of_string "files_recursively_in" + ; String_with_vars.sexp_of_t t ] | Package t -> - List [Sexp.unsafe_atom_of_string "package" ; - String_with_vars.sexp_of_t t] + List [ Sexp.unsafe_atom_of_string "package" + ; String_with_vars.sexp_of_t t] | Universe -> Sexp.unsafe_atom_of_string "universe" end From 1cc0198d9c34cb6411809ab9ffba4b6f9011eb34 Mon Sep 17 00:00:00 2001 From: Rudi Grinberg Date: Mon, 9 Jul 2018 00:06:02 +0700 Subject: [PATCH 07/34] Make the tests stanza use named deps Signed-off-by: Rudi Grinberg --- src/gen_rules.ml | 2 +- src/jbuild.ml | 4 ++-- src/jbuild.mli | 4 +++- 3 files changed, 6 insertions(+), 4 deletions(-) diff --git a/src/gen_rules.ml b/src/gen_rules.ml index b853de4e..97e0a4a6 100644 --- a/src/gen_rules.ml +++ b/src/gen_rules.ml @@ -976,7 +976,7 @@ module Gen(P : Install_rules.Params) = struct let rule = { Rule. targets = Infer - ; deps = [] + ; deps = Named.empty ; action = (loc, Action.Unexpanded.Redirect (Stdout, diff.file2, run_action)) ; mode = Standard diff --git a/src/jbuild.ml b/src/jbuild.ml index 00033933..a56044ed 100644 --- a/src/jbuild.ml +++ b/src/jbuild.ml @@ -1420,7 +1420,7 @@ module Tests = struct { exes : Executables.t ; locks : String_with_vars.t list ; package : Package.t option - ; deps : Dep_conf.t list + ; deps : Dep_conf.t Named.t } let gen_parse names = @@ -1428,7 +1428,7 @@ module Tests = struct (Buildable.t >>= fun buildable -> field_oslu "link_flags" >>= fun link_flags -> names >>= fun names -> - field "deps" (list Dep_conf.t) ~default:[] >>= fun deps -> + field "deps" Dep_conf.bindings ~default:Named.empty >>= fun deps -> field_o "package" Pkg.t >>= fun package -> field "locks" (list String_with_vars.t) ~default:[] >>= fun locks -> field "modes" Executables.Link_mode.Set.t diff --git a/src/jbuild.mli b/src/jbuild.mli index 50b394e8..efba5409 100644 --- a/src/jbuild.mli +++ b/src/jbuild.mli @@ -87,6 +87,8 @@ module Named : sig ; unnamed : 'a list } + val empty : 'a t + val sexp_of_t : ('a -> Usexp.t) -> 'a t -> Usexp.t end @@ -359,7 +361,7 @@ module Tests : sig { exes : Executables.t ; locks : String_with_vars.t list ; package : Package.t option - ; deps : Dep_conf.t list + ; deps : Dep_conf.t Named.t } end From 2b7a7fcdffdb089a7a5292cf5b1c77f098ef53fa Mon Sep 17 00:00:00 2001 From: Rudi Grinberg Date: Mon, 9 Jul 2018 20:10:45 +0700 Subject: [PATCH 08/34] Expand named variables in actions Signed-off-by: Rudi Grinberg --- src/inline_tests.ml | 2 +- src/jbuild.ml | 31 ++++++++++++++++++------ src/jbuild.mli | 8 ++++++- src/preprocessing.ml | 4 ++-- src/super_context.ml | 55 +++++++++++++++++++++++++++++++------------ src/super_context.mli | 4 ++-- 6 files changed, 76 insertions(+), 28 deletions(-) diff --git a/src/inline_tests.ml b/src/inline_tests.ml index 76e407a6..16296a12 100644 --- a/src/inline_tests.ml +++ b/src/inline_tests.ml @@ -214,7 +214,7 @@ include Sub_system.Register_end_point( ~init:extra_vars ~f:(fun acc (k, v) -> String.Map.add acc k v) in - Build.return [] + Build.return Named.empty >>> Build.all (List.filter_map backends ~f:(fun (backend : Backend.t) -> diff --git a/src/jbuild.ml b/src/jbuild.ml index a56044ed..1f250a06 100644 --- a/src/jbuild.ml +++ b/src/jbuild.ml @@ -234,15 +234,31 @@ end module Named = struct type 'a t = - { named: (Loc.t * 'a list) String.Map.t + { named: 'a list String.Map.t ; unnamed : 'a list } + let fold { named; unnamed } ~f ~init = + let flipped x acc = f acc x in + String.Map.fold named + ~f:(fun x init -> List.fold_left ~f:flipped ~init x) + ~init:(List.fold_left ~f:flipped ~init unnamed) + + let first { named; unnamed } = + if String.Map.is_empty named then + match unnamed with + | [] -> Result.Error `Empty + | x :: _ -> Ok x + else + Result.Error `Named_exists + let empty = { named = String.Map.empty ; unnamed = [] } + let singleton x = { empty with unnamed = [x] } + let t elem = let binding = peek_exn >>= function @@ -262,17 +278,18 @@ module Named = struct let (named, unnamed) = List.partition_map bindings ~f:(fun x -> x) in { unnamed = List.flatten unnamed ; named = - match String.Map.of_list named with - | Ok x -> x - | Error (name, (l1, _), (l2, _)) -> - of_sexp_errorf l1 "Variable %s is already defined in %s" - name (Loc.to_file_colon_line l2) + (match String.Map.of_list named with + | Ok x -> x + | Error (name, (l1, _), (l2, _)) -> + of_sexp_errorf l1 "Variable %s is already defined in %s" + name (Loc.to_file_colon_line l2)) + |> String.Map.map ~f:snd }) let sexp_of_t sexp_of_a { unnamed; named } = let unnamed = List.map ~f:sexp_of_a unnamed in let named = - String.Map.foldi ~init:[] named ~f:(fun n (_, d) acc -> + String.Map.foldi ~init:[] named ~f:(fun n d acc -> Sexp.unsafe_atom_of_string (":" ^ n) :: (List.map ~f:sexp_of_a d) @ acc) in Sexp.List (unnamed @ named) diff --git a/src/jbuild.mli b/src/jbuild.mli index efba5409..8b9e3979 100644 --- a/src/jbuild.mli +++ b/src/jbuild.mli @@ -83,12 +83,18 @@ end module Named : sig type 'a t = - { named : (Loc.t * 'a list) String.Map.t + { named : 'a list String.Map.t ; unnamed : 'a list } val empty : 'a t + val singleton : 'a -> 'a t + + val first : 'a t -> ('a, [`Empty | `Named_exists]) Result.t + + val fold : 'a t -> f:('a -> 'init -> 'init) -> init:'init -> 'init + val sexp_of_t : ('a -> Usexp.t) -> 'a t -> Usexp.t end diff --git a/src/preprocessing.ml b/src/preprocessing.ml index fad3f8cd..799c8926 100644 --- a/src/preprocessing.ml +++ b/src/preprocessing.ml @@ -456,7 +456,7 @@ let lint_module sctx ~dir ~dep_kind ~lint ~lib_name ~scope ~dir_kind = let src_path = Path.relative dir src.name in add_alias src.name (Build.path src_path - >>^ (fun _ -> [src_path]) + >>^ (fun _ -> Jbuild.Named.singleton src_path) >>> SC.Action.run sctx action ~loc @@ -531,7 +531,7 @@ let make sctx ~dir ~dep_kind ~lint ~preprocess (preprocessor_deps >>> Build.path src - >>^ (fun _ -> [src]) + >>^ (fun _ -> Jbuild.Named.singleton src) >>> SC.Action.run sctx (Redirect diff --git a/src/super_context.ml b/src/super_context.ml index 7393410f..dd024ebf 100644 --- a/src/super_context.ml +++ b/src/super_context.ml @@ -528,11 +528,20 @@ module Deps = struct >>^ List.concat let interpret_named t ~scope ~dir { Named.unnamed; named } = - String.Map.fold ~init:unnamed named ~f:(fun (_, ds) acc -> - List.rev_append ds acc) - |> List.map ~f:(dep t ~scope ~dir) - |> Build.all - >>^ List.concat + let deps l = + List.map ~f:(dep t ~scope ~dir) l + |> Build.all + >>^ List.concat + in + let unnamed = deps unnamed in + let named = + String.Map.to_list named + |> List.map ~f:(fun (k, d) -> deps d >>^ fun d -> (k, d)) + |> Build.all + >>^ String.Map.of_list_exn + in + unnamed &&& named >>^ fun (unnamed, named) -> + { Named.unnamed; named } end module Pkg_version = struct @@ -762,31 +771,47 @@ module Action = struct let t = U.partial_expand t ~dir ~map_exe ~f:expand in (t, acc) - let expand_step2 ~dir ~dynamic_expansions ~deps_written_by_user ~map_exe t = + let expand_step2 ~dir ~dynamic_expansions + ~(deps_written_by_user : Path.t Jbuild.Named.t) + ~map_exe t = U.Partial.expand t ~dir ~map_exe ~f:(fun var syntax_version -> let key = String_with_vars.Var.full_name var in let loc = String_with_vars.Var.loc var in match String.Map.find dynamic_expansions key with | Some _ as opt -> opt | None -> - Pform.Map.expand Pform.Map.static_vars ~syntax_version ~var - |> Option.map ~f:(function - | Pform.Var.Deps -> (Value.L.paths deps_written_by_user) + begin match + Pform.Map.expand Pform.Map.static_vars ~syntax_version ~var + with + | None -> + String.Map.find deps_written_by_user.named key + |> Option.map ~f:Value.L.paths + | Some x -> + begin match x with + Pform.Var.Deps -> + deps_written_by_user + |> Jbuild.Named.fold ~init:[] ~f:List.cons + |> Value.L.paths + |> Option.some | First_dep -> - begin match deps_written_by_user with - | [] -> + begin match Jbuild.Named.first deps_written_by_user with + | Error `Named_exists -> + Loc.fail loc "%%{first-dep} is not allowed with named dependencies" + | Error `Empty -> Loc.warn loc "Variable '%s' used with no explicit \ dependencies@." key; - [Value.String ""] - | v :: _ -> [Path v] + Some [Value.String ""] + | Ok v -> Some [Path v] end | _ -> Exn.code_error "Unexpected variable in step2" - ["var", String_with_vars.Var.sexp_of_t var])) + ["var", String_with_vars.Var.sexp_of_t var] + end + end) let run sctx ~loc ?(extra_vars=String.Map.empty) t ~dir ~dep_kind ~targets:targets_written_by_user ~scope - : (Path.t list, Action.t) Build.t = + : (Path.t Named.t, Action.t) Build.t = let map_exe = map_exe sctx in if targets_written_by_user = Alias then begin match Action.Infer.unexpanded_targets t with diff --git a/src/super_context.mli b/src/super_context.mli index eb86dd28..f7ba8137 100644 --- a/src/super_context.mli +++ b/src/super_context.mli @@ -225,7 +225,7 @@ module Deps : sig -> scope:Scope.t -> dir:Path.t -> Dep_conf.t Named.t - -> (unit, Path.t list) Build.t + -> (unit, Path.t Named.t) Build.t end (** Interpret action written in jbuild files *) @@ -245,7 +245,7 @@ module Action : sig -> dep_kind:Build.lib_dep_kind -> targets:targets -> scope:Scope.t - -> (Path.t list, Action.t) Build.t + -> (Path.t Named.t, Action.t) Build.t end module Pkg_version : sig From 8fa41edcffdd5b4e66f5f6e53a4c36ad483ba6af Mon Sep 17 00:00:00 2001 From: Rudi Grinberg Date: Mon, 9 Jul 2018 21:18:24 +0700 Subject: [PATCH 09/34] Parse bindings in the new syntax Signed-off-by: Rudi Grinberg --- src/jbuild.ml | 30 +++++-------------- src/stdune/sexp.ml | 20 +++++++++++++ src/stdune/sexp.mli | 2 ++ test/blackbox-tests/test-cases/dep-vars/dune | 2 +- .../test-cases/merlin-tests/run.t | 24 +++++++-------- test/blackbox-tests/test-cases/misc/run.t | 21 +++++++++++-- 6 files changed, 62 insertions(+), 37 deletions(-) diff --git a/src/jbuild.ml b/src/jbuild.ml index 1f250a06..db050cb4 100644 --- a/src/jbuild.ml +++ b/src/jbuild.ml @@ -262,21 +262,16 @@ module Named = struct let t elem = let binding = peek_exn >>= function - | Atom (loc, A s) when String.length s > 1 && s.[0] = ':' -> - begin - string >>= fun name -> - peek >>= function - | None -> of_sexp_errorf loc "Naked binding %s" s - | Some _ -> - elem >>| fun elem -> - Left (name, (loc, elem)) - end + | List (_, Atom (loc, A s) :: _) when + String.length s > 1 && s.[0] = ':' -> + binding elem >>| fun (name, values) -> + Left (name, (loc, values)) | _ -> elem >>| fun elem -> Right elem in list binding >>| (fun bindings -> let (named, unnamed) = List.partition_map bindings ~f:(fun x -> x) in - { unnamed = List.flatten unnamed + { unnamed ; named = (match String.Map.of_list named with | Ok x -> x @@ -331,15 +326,6 @@ module Dep_conf = struct let t = make_dep_parser ~single:(fun x -> x) ~many:(sum dep_cons) - let bindings = - let dep = - make_dep_parser ~single:List.singleton ~many:( - ("list", repeat t) - :: List.map dep_cons ~f:(fun (n, d) -> (n, d >>| List.singleton)) - |> sum) - in - Named.t dep - open Sexp let sexp_of_t = function | File t -> @@ -1202,7 +1188,7 @@ module Rule = struct >>= fun action -> field "targets" (list file_in_current_dir) >>= fun targets -> - field "deps" Dep_conf.bindings ~default:Named.empty + field "deps" (Named.t Dep_conf.t) ~default:Named.empty >>= fun deps -> field "locks" (list String_with_vars.t) ~default:[] >>= fun locks -> map_validate @@ -1421,7 +1407,7 @@ module Alias_conf = struct field_o "package" Pkg.t >>= fun package -> field_o "action" (located Action.Unexpanded.t) >>= fun action -> field "locks" (list String_with_vars.t) ~default:[] >>= fun locks -> - field "deps" Dep_conf.bindings ~default:Named.empty + field "deps" (Named.t Dep_conf.t) ~default:Named.empty >>= fun deps -> return { name @@ -1445,7 +1431,7 @@ module Tests = struct (Buildable.t >>= fun buildable -> field_oslu "link_flags" >>= fun link_flags -> names >>= fun names -> - field "deps" Dep_conf.bindings ~default:Named.empty >>= fun deps -> + field "deps" (Named.t Dep_conf.t) ~default:Named.empty >>= fun deps -> field_o "package" Pkg.t >>= fun package -> field "locks" (list String_with_vars.t) ~default:[] >>= fun locks -> field "modes" Executables.Link_mode.Set.t diff --git a/src/stdune/sexp.ml b/src/stdune/sexp.ml index 01134809..651e4688 100644 --- a/src/stdune/sexp.ml +++ b/src/stdune/sexp.ml @@ -380,6 +380,26 @@ module Of_sexp = struct } "Unknown constructor %s" name + let binding t = + let t name = repeat t >>| fun t -> (name, t) in + next_with_user_context (fun uc sexp -> + match sexp with + | Atom (loc, A s) -> + let ctx = Values (loc, Some s, uc) in + result ctx (t s ctx []) + | Template { loc; _ } + | Quoted_string (loc, _) -> + of_sexp_error loc "Atom expected" + | List (loc, []) -> + of_sexp_error loc "Non-empty list expected" + | List (loc, name :: args) -> + match name with + | Quoted_string (loc, _) | List (loc, _) | Template { loc; _ } -> + of_sexp_error loc "Atom expected" + | Atom (s_loc, A s) -> + let ctx loc = Values (loc, Some s, uc) in + result (ctx s_loc) (t s (ctx loc) args)) + let sum cstrs = next_with_user_context (fun uc sexp -> match sexp with diff --git a/src/stdune/sexp.mli b/src/stdune/sexp.mli index 948a3d80..de2aa7ee 100644 --- a/src/stdune/sexp.mli +++ b/src/stdune/sexp.mli @@ -201,6 +201,8 @@ module Of_sexp : sig list parser. *) val sum : (string * 'a t) list -> 'a t + val binding : 'a t -> (string * ('a list)) t + (** Check the result of a list parser, and raise a properly located error in case of failure. *) val map_validate diff --git a/test/blackbox-tests/test-cases/dep-vars/dune b/test/blackbox-tests/test-cases/dep-vars/dune index cd26888c..96a8945f 100644 --- a/test/blackbox-tests/test-cases/dep-vars/dune +++ b/test/blackbox-tests/test-cases/dep-vars/dune @@ -1,5 +1,5 @@ (rule - (deps :foo (list a b) :baz foo (list (alias test)) (list a b c)) + (deps (:foo a b) (:baz foo (alias test)) a b c) (targets bar) (action (with-stdout-to bar (echo "foo")))) diff --git a/test/blackbox-tests/test-cases/merlin-tests/run.t b/test/blackbox-tests/test-cases/merlin-tests/run.t index 91b53db1..b1659de9 100644 --- a/test/blackbox-tests/test-cases/merlin-tests/run.t +++ b/test/blackbox-tests/test-cases/merlin-tests/run.t @@ -4,18 +4,6 @@ ocamlopt sanitize-dot-merlin/.sanitize_dot_merlin.eobjs/sanitize_dot_merlin.{cmx,o} ocamlopt sanitize-dot-merlin/sanitize_dot_merlin.exe sanitize_dot_merlin alias print-merlins - # Processing exe/.merlin - B $LIB_PREFIX/lib/bytes - B $LIB_PREFIX/lib/findlib - B $LIB_PREFIX/lib/ocaml - B ../_build/default/exe/.x.eobjs - B ../_build/default/lib/.foo.objs - S $LIB_PREFIX/lib/bytes - S $LIB_PREFIX/lib/findlib - S $LIB_PREFIX/lib/ocaml - S . - S ../lib - FLG -w -40 # Processing lib/.merlin B $LIB_PREFIX/lib/bytes B $LIB_PREFIX/lib/findlib @@ -28,6 +16,18 @@ S . FLG -ppx '$PPX/fooppx@./ppx.exe --as-ppx --cookie '\''library-name="foo"'\''' FLG -open Foo -w -40 -open Bar -w -40 + # Processing exe/.merlin + B $LIB_PREFIX/lib/bytes + B $LIB_PREFIX/lib/findlib + B $LIB_PREFIX/lib/ocaml + B ../_build/default/exe/.x.eobjs + B ../_build/default/lib/.foo.objs + S $LIB_PREFIX/lib/bytes + S $LIB_PREFIX/lib/findlib + S $LIB_PREFIX/lib/ocaml + S . + S ../lib + FLG -w -40 Make sure a ppx directive is generated diff --git a/test/blackbox-tests/test-cases/misc/run.t b/test/blackbox-tests/test-cases/misc/run.t index 4b02d83e..0cc002ad 100644 --- a/test/blackbox-tests/test-cases/misc/run.t +++ b/test/blackbox-tests/test-cases/misc/run.t @@ -2,5 +2,22 @@ File "dune", line 44, characters 19-42: Warning: Directory dir-that-doesnt-exist doesn't exist. diff alias runtest - diff alias runtest - diff alias runtest + diff alias runtest (exit 1) + (cd _build/default && /usr/bin/diff -u result expected) + --- result 2018-07-09 21:13:11.000000000 +0700 + +++ expected 2018-07-09 21:13:11.000000000 +0700 + @@ -1 +1 @@ + -c.txt b.txt a.txt dune + \ No newline at end of file + +dune a.txt b.txt c.txt + \ No newline at end of file + diff alias runtest (exit 1) + (cd _build/default && /usr/bin/diff -u result2 expected2) + --- result2 2018-07-09 21:13:11.000000000 +0700 + +++ expected2 2018-07-09 21:13:11.000000000 +0700 + @@ -1 +1 @@ + -sub-tree/dir/b sub-tree/a + \ No newline at end of file + +sub-tree/a sub-tree/dir/b + \ No newline at end of file + [1] From fd27e371bc3f72833bf0785454770e8563758cf8 Mon Sep 17 00:00:00 2001 From: Jeremie Dimino Date: Mon, 9 Jul 2018 15:46:39 +0100 Subject: [PATCH 10/34] Tweak parsing of bindings Signed-off-by: Jeremie Dimino --- src/jbuild.ml | 6 ++++-- src/stdune/sexp.ml | 20 -------------------- src/stdune/sexp.mli | 2 -- 3 files changed, 4 insertions(+), 24 deletions(-) diff --git a/src/jbuild.ml b/src/jbuild.ml index db050cb4..ec76cdc2 100644 --- a/src/jbuild.ml +++ b/src/jbuild.ml @@ -264,8 +264,10 @@ module Named = struct peek_exn >>= function | List (_, Atom (loc, A s) :: _) when String.length s > 1 && s.[0] = ':' -> - binding elem >>| fun (name, values) -> - Left (name, (loc, values)) + let name = String.sub s ~pos:1 ~len:(String.length s - 1) in + enter (junk >>= fun () -> + repeat elem >>| fun values -> + Left (name, (loc, values))) | _ -> elem >>| fun elem -> Right elem in diff --git a/src/stdune/sexp.ml b/src/stdune/sexp.ml index 651e4688..01134809 100644 --- a/src/stdune/sexp.ml +++ b/src/stdune/sexp.ml @@ -380,26 +380,6 @@ module Of_sexp = struct } "Unknown constructor %s" name - let binding t = - let t name = repeat t >>| fun t -> (name, t) in - next_with_user_context (fun uc sexp -> - match sexp with - | Atom (loc, A s) -> - let ctx = Values (loc, Some s, uc) in - result ctx (t s ctx []) - | Template { loc; _ } - | Quoted_string (loc, _) -> - of_sexp_error loc "Atom expected" - | List (loc, []) -> - of_sexp_error loc "Non-empty list expected" - | List (loc, name :: args) -> - match name with - | Quoted_string (loc, _) | List (loc, _) | Template { loc; _ } -> - of_sexp_error loc "Atom expected" - | Atom (s_loc, A s) -> - let ctx loc = Values (loc, Some s, uc) in - result (ctx s_loc) (t s (ctx loc) args)) - let sum cstrs = next_with_user_context (fun uc sexp -> match sexp with diff --git a/src/stdune/sexp.mli b/src/stdune/sexp.mli index de2aa7ee..948a3d80 100644 --- a/src/stdune/sexp.mli +++ b/src/stdune/sexp.mli @@ -201,8 +201,6 @@ module Of_sexp : sig list parser. *) val sum : (string * 'a t) list -> 'a t - val binding : 'a t -> (string * ('a list)) t - (** Check the result of a list parser, and raise a properly located error in case of failure. *) val map_validate From 04f62ecc03636f342cd21a145d0e05aed1c61fb6 Mon Sep 17 00:00:00 2001 From: Jeremie Dimino Date: Mon, 9 Jul 2018 16:03:52 +0100 Subject: [PATCH 11/34] Get rid of uses of %{first-dep} Signed-off-by: Jeremie Dimino --- src/jbuild.ml | 4 +- .../blackbox-tests/test-cases/force-test/dune | 8 +--- test/blackbox-tests/test-cases/github568/dune | 6 +-- .../github660/explicit-interfaces/dune | 3 +- .../test-cases/github660/no-interfaces/dune | 3 +- test/blackbox-tests/test-cases/misc/run.t | 8 ++-- .../blackbox-tests/test-cases/output-obj/dune | 6 +-- test/blackbox-tests/test-cases/select/dune | 3 +- test/unit-tests/configurator/dune | 7 +--- test/unit-tests/dune | 42 +++++++++---------- test/unit-tests/ocaml-config/dune | 7 +--- 11 files changed, 38 insertions(+), 59 deletions(-) diff --git a/src/jbuild.ml b/src/jbuild.ml index ec76cdc2..04fb383c 100644 --- a/src/jbuild.ml +++ b/src/jbuild.ml @@ -1307,7 +1307,7 @@ module Rule = struct [ S.virt_text __POS__ "-q" ; S.virt_text __POS__ "-o" ; S.virt_var __POS__ "targets" - ; S.virt_var __POS__"first-dep" + ; S.virt_var __POS__"first-dep-tmp" ]))) ; mode ; locks = [] @@ -1328,7 +1328,7 @@ module Rule = struct Chdir (S.virt_var __POS__ "root", Run (S.virt_text __POS__ "ocamlyacc", - [S.virt_var __POS__ "first-dep"]))) + [S.virt_var __POS__ "first-dep-tmp"]))) ; mode ; locks = [] ; loc diff --git a/test/blackbox-tests/test-cases/force-test/dune b/test/blackbox-tests/test-cases/force-test/dune index 51e83746..6266b359 100644 --- a/test/blackbox-tests/test-cases/force-test/dune +++ b/test/blackbox-tests/test-cases/force-test/dune @@ -1,7 +1 @@ -(executable - (name f)) - -(alias - (name runtest) - (deps f.exe) - (action (run %{first-dep}))) +(test (name f)) diff --git a/test/blackbox-tests/test-cases/github568/dune b/test/blackbox-tests/test-cases/github568/dune index 46bee013..62257193 100644 --- a/test/blackbox-tests/test-cases/github568/dune +++ b/test/blackbox-tests/test-cases/github568/dune @@ -7,8 +7,7 @@ (alias (name runtest) (package lib1) - (deps test1.exe) - (action (run %{first-dep}))) + (action (run ./test1.exe))) (executable (name test1) @@ -24,8 +23,7 @@ (alias (name runtest) (package lib2) - (deps test2.exe) - (action (run %{first-dep}))) + (action (run ./test2.exe))) (executable (name test2) diff --git a/test/blackbox-tests/test-cases/github660/explicit-interfaces/dune b/test/blackbox-tests/test-cases/github660/explicit-interfaces/dune index 7817f984..beef01da 100644 --- a/test/blackbox-tests/test-cases/github660/explicit-interfaces/dune +++ b/test/blackbox-tests/test-cases/github660/explicit-interfaces/dune @@ -1,6 +1,5 @@ (alias (name runtest) - (deps main.exe) - (action (run %{first-dep}))) + (action (run ./main.exe))) (executable (name main)) diff --git a/test/blackbox-tests/test-cases/github660/no-interfaces/dune b/test/blackbox-tests/test-cases/github660/no-interfaces/dune index 7817f984..beef01da 100644 --- a/test/blackbox-tests/test-cases/github660/no-interfaces/dune +++ b/test/blackbox-tests/test-cases/github660/no-interfaces/dune @@ -1,6 +1,5 @@ (alias (name runtest) - (deps main.exe) - (action (run %{first-dep}))) + (action (run ./main.exe))) (executable (name main)) diff --git a/test/blackbox-tests/test-cases/misc/run.t b/test/blackbox-tests/test-cases/misc/run.t index 0cc002ad..b0a157f5 100644 --- a/test/blackbox-tests/test-cases/misc/run.t +++ b/test/blackbox-tests/test-cases/misc/run.t @@ -4,8 +4,8 @@ diff alias runtest diff alias runtest (exit 1) (cd _build/default && /usr/bin/diff -u result expected) - --- result 2018-07-09 21:13:11.000000000 +0700 - +++ expected 2018-07-09 21:13:11.000000000 +0700 + --- result 2018-07-09 16:03:03.123914026 +0100 + +++ expected 2018-07-09 16:03:03.124914029 +0100 @@ -1 +1 @@ -c.txt b.txt a.txt dune \ No newline at end of file @@ -13,8 +13,8 @@ \ No newline at end of file diff alias runtest (exit 1) (cd _build/default && /usr/bin/diff -u result2 expected2) - --- result2 2018-07-09 21:13:11.000000000 +0700 - +++ expected2 2018-07-09 21:13:11.000000000 +0700 + --- result2 2018-07-09 16:03:03.124914029 +0100 + +++ expected2 2018-07-09 16:03:03.124914029 +0100 @@ -1 +1 @@ -sub-tree/dir/b sub-tree/a \ No newline at end of file diff --git a/test/blackbox-tests/test-cases/output-obj/dune b/test/blackbox-tests/test-cases/output-obj/dune index 591b5ab5..598ef9f3 100644 --- a/test/blackbox-tests/test-cases/output-obj/dune +++ b/test/blackbox-tests/test-cases/output-obj/dune @@ -33,7 +33,7 @@ (rule (targets dynamic.exe) (deps dynamic.c) - (action (run %{cc} -o %{targets} %{first-dep} %{ocaml-config:native_c_libraries}))) + (action (run %{cc} -o %{targets} %{deps} %{ocaml-config:native_c_libraries}))) (alias (name runtest) @@ -48,9 +48,9 @@ (alias (name runtest) (deps test.bc%{ext_dll}) - (action (run ./dynamic.exe ./%{first-dep}))) + (action (run ./dynamic.exe ./%{deps}))) (alias (name runtest) (deps test%{ext_dll}) - (action (run ./dynamic.exe ./%{first-dep}))) + (action (run ./dynamic.exe ./%{deps}))) diff --git a/test/blackbox-tests/test-cases/select/dune b/test/blackbox-tests/test-cases/select/dune index 4e6a6b1f..a25653ec 100644 --- a/test/blackbox-tests/test-cases/select/dune +++ b/test/blackbox-tests/test-cases/select/dune @@ -10,5 +10,4 @@ (alias (name runtest) - (deps main.exe) - (action (run %{first-dep}))) + (action (run ./main.exe))) diff --git a/test/unit-tests/configurator/dune b/test/unit-tests/configurator/dune index 1e259288..034d70a9 100644 --- a/test/unit-tests/configurator/dune +++ b/test/unit-tests/configurator/dune @@ -1,8 +1,3 @@ -(executable +(test (name test_configurator) (libraries configurator)) - -(alias - (name runtest) - (deps ./test_configurator.exe) - (action (run %{first-dep}))) diff --git a/test/unit-tests/dune b/test/unit-tests/dune index 7ee04560..aa2f0eef 100644 --- a/test/unit-tests/dune +++ b/test/unit-tests/dune @@ -18,72 +18,72 @@ (alias (name runtest) - (deps tests.mlt + (deps (:t tests.mlt) (glob_files %{project_root}/src/.dune.objs/*.cmi) (glob_files %{project_root}/src/stdune/.stdune.objs/*.cmi) (source_tree toolchain.d) (source_tree findlib-db)) (action (chdir %{project_root} (progn - (run %{exe:expect_test.exe} %{first-dep}) - (diff? %{first-dep} %{first-dep}.corrected))))) + (run %{exe:expect_test.exe} %{t}) + (diff? %{t} %{t}.corrected))))) (alias (name runtest) - (deps filename.mlt + (deps (:t filename.mlt) (glob_files %{project_root}/src/.dune.objs/*.cmi) (glob_files %{project_root}/src/stdune/.stdune.objs/*.cmi)) (action (chdir %{project_root} (progn - (run %{exe:expect_test.exe} %{first-dep}) - (diff? %{first-dep} %{first-dep}.corrected))))) + (run %{exe:expect_test.exe} %{t}) + (diff? %{t} %{t}.corrected))))) (alias (name runtest) - (deps import_dot_map.mlt + (deps (:t import_dot_map.mlt) (glob_files %{project_root}/src/.dune.objs/*.cmi) (glob_files %{project_root}/src/stdune/.stdune.objs/*.cmi)) (action (chdir %{project_root} (progn - (run %{exe:expect_test.exe} %{first-dep}) - (diff? %{first-dep} %{first-dep}.corrected))))) + (run %{exe:expect_test.exe} %{t}) + (diff? %{t} %{t}.corrected))))) (alias (name runtest) - (deps action.mlt + (deps (:t action.mlt) (glob_files %{project_root}/src/.dune.objs/*.cmi) (glob_files %{project_root}/src/stdune/.stdune.objs/*.cmi)) (action (chdir %{project_root} (progn - (run %{exe:expect_test.exe} %{first-dep}) - (diff? %{first-dep} %{first-dep}.corrected))))) + (run %{exe:expect_test.exe} %{t}) + (diff? %{t} %{t}.corrected))))) (alias (name runtest) - (deps path.mlt + (deps (:t path.mlt) (glob_files %{project_root}/src/.dune.objs/*.cmi) (glob_files %{project_root}/src/stdune/.stdune.objs/*.cmi)) (action (chdir %{project_root} (progn - (run %{exe:expect_test.exe} %{first-dep}) - (diff? %{first-dep} %{first-dep}.corrected))))) + (run %{exe:expect_test.exe} %{t}) + (diff? %{t} %{t}.corrected))))) (alias (name runtest) - (deps sexp.mlt + (deps (:t sexp.mlt) (glob_files %{project_root}/src/.dune.objs/*.cmi) (glob_files %{project_root}/src/stdune/.stdune.objs/*.cmi)) (action (chdir %{project_root} (progn - (run %{exe:expect_test.exe} %{first-dep}) - (diff? %{first-dep} %{first-dep}.corrected))))) + (run %{exe:expect_test.exe} %{t}) + (diff? %{t} %{t}.corrected))))) (alias (name runtest) - (deps jbuild.mlt + (deps (:t jbuild.mlt) (glob_files %{project_root}/src/.dune.objs/*.cmi) (glob_files %{project_root}/src/stdune/.stdune.objs/*.cmi)) (action (chdir %{project_root} (progn - (run %{exe:expect_test.exe} %{first-dep}) - (diff? %{first-dep} %{first-dep}.corrected))))) + (run %{exe:expect_test.exe} %{t}) + (diff? %{t} %{t}.corrected))))) diff --git a/test/unit-tests/ocaml-config/dune b/test/unit-tests/ocaml-config/dune index 659d3aa3..cb4d4096 100644 --- a/test/unit-tests/ocaml-config/dune +++ b/test/unit-tests/ocaml-config/dune @@ -1,8 +1,3 @@ -(executable +(test (name gh637) (libraries ocaml_config)) - -(alias - (name runtest) - (deps ./gh637.exe) - (action (run %{first-dep}))) From df15d30845a0ac42baa8551bb617f0538fc79548 Mon Sep 17 00:00:00 2001 From: Jeremie Dimino Date: Mon, 9 Jul 2018 16:18:49 +0100 Subject: [PATCH 12/34] Completely get rid of first-dep Signed-off-by: Jeremie Dimino --- doc/migration.rst | 21 +++++++++++++++++-- src/jbuild.ml | 4 ++-- src/pform.ml | 20 +++++++++--------- src/pform.mli | 2 +- src/syntax.ml | 7 +++++-- src/syntax.mli | 8 ++++++- .../test-cases/syntax-versioning/run.t | 8 +++++++ 7 files changed, 52 insertions(+), 18 deletions(-) diff --git a/doc/migration.rst b/doc/migration.rst index a50fd0cb..d85670d6 100644 --- a/doc/migration.rst +++ b/doc/migration.rst @@ -169,7 +169,6 @@ Jbuild Dune ======================== ============ ``${@}`` ``%{targets}`` ``${^}`` ``%{deps}`` -``${<}`` ``%{first-dep}`` ``${path:file}`` ``%{dep:file}`` ``${SCOPE_ROOT}`` ``%{project_root}`` ``${findlib:..}`` ``%{lib:..}`` @@ -186,8 +185,26 @@ Jbuild Dune Removed Variables ----------------- -``${path-no-dep:file}`` has been removed. +``${path-no-dep:file}`` and ``${<}`` have been removed. +A named dependency should be used instead of ``${<}``. For instance +the following jbuild file: + +.. code:: scheme + + (alias + ((name runtest) + (deps (input)) + (action (run ./test.exe %{<})))) + +should be rewritten to the following dune file: + +.. code:: scheme + + (alias + (name runtest) + (deps (:x input)) + (action (run ./test.exe %{x}))) ``# JBUILDER_GEN`` renamed -------------------------- diff --git a/src/jbuild.ml b/src/jbuild.ml index 04fb383c..2be16d07 100644 --- a/src/jbuild.ml +++ b/src/jbuild.ml @@ -1307,7 +1307,7 @@ module Rule = struct [ S.virt_text __POS__ "-q" ; S.virt_text __POS__ "-o" ; S.virt_var __POS__ "targets" - ; S.virt_var __POS__"first-dep-tmp" + ; S.virt_var __POS__"deps" ]))) ; mode ; locks = [] @@ -1328,7 +1328,7 @@ module Rule = struct Chdir (S.virt_var __POS__ "root", Run (S.virt_text __POS__ "ocamlyacc", - [S.virt_var __POS__ "first-dep-tmp"]))) + [S.virt_var __POS__ "deps"]))) ; mode ; locks = [] ; loc diff --git a/src/pform.ml b/src/pform.ml index 58e1858b..587cff57 100644 --- a/src/pform.ml +++ b/src/pform.ml @@ -36,24 +36,24 @@ end type 'a t = | No_info of 'a | Since of 'a * Syntax.Version.t - | Deleted_in of 'a * Syntax.Version.t + | Deleted_in of 'a * Syntax.Version.t * string option | Renamed_in of Syntax.Version.t * string module Map = struct type nonrec 'a t = 'a t String.Map.t - let values v = No_info (Var.Values v) - let renamed_in ~new_name ~version = Renamed_in (version, new_name) - let deleted_in ~version kind = Deleted_in (kind, version) - let since ~version v = Since (v, version) + let values v = No_info (Var.Values v) + let renamed_in ~new_name ~version = Renamed_in (version, new_name) + let deleted_in ~version ?repl kind = Deleted_in (kind, version, repl) + let since ~version v = Since (v, version) let static_vars = - [ "first-dep", since ~version:(1, 0) Var.First_dep - ; "targets", since ~version:(1, 0) Var.Targets + [ "targets", since ~version:(1, 0) Var.Targets ; "deps", since ~version:(1, 0) Var.Deps ; "project_root", since ~version:(1, 0) Var.Project_root - ; "<", renamed_in ~version:(1, 0) ~new_name:"first-dep" + ; "<", deleted_in Var.Deps ~version:(1, 0) + ~repl:"Use a named dependency instead: (: )" ; "@", renamed_in ~version:(1, 0) ~new_name:"targets" ; "^", renamed_in ~version:(1, 0) ~new_name:"deps" ; "SCOPE_ROOT", renamed_in ~version:(1, 0) ~new_name:"project_root" @@ -167,10 +167,10 @@ module Map = struct expand t ~syntax_version:in_version ~var:(String_with_vars.Var.with_name var ~name:new_name) end - | Deleted_in (v, in_version) -> + | Deleted_in (v, in_version, repl) -> if syntax_version < in_version then Some v else Syntax.Error.deleted_in (String_with_vars.Var.loc var) - Stanza.syntax syntax_version ~what:(what var)) + Stanza.syntax syntax_version ~what:(what var) ?repl) end diff --git a/src/pform.mli b/src/pform.mli index 357a3a16..71ab99ae 100644 --- a/src/pform.mli +++ b/src/pform.mli @@ -28,7 +28,7 @@ end type 'a t = | No_info of 'a | Since of 'a * Syntax.Version.t - | Deleted_in of 'a * Syntax.Version.t + | Deleted_in of 'a * Syntax.Version.t * string option | Renamed_in of Syntax.Version.t * string module Map : sig diff --git a/src/syntax.ml b/src/syntax.ml index 3e778dc2..8ea07e32 100644 --- a/src/syntax.ml +++ b/src/syntax.ml @@ -65,9 +65,12 @@ module Error = struct Loc.fail loc "%s was renamed to '%s' in the %s version of %s" what to_ (Version.to_string ver) t.desc - let deleted_in loc t ver ~what = - Loc.fail loc "%s was deleted in version %s of %s" + let deleted_in loc t ?repl ver ~what = + Loc.fail loc "%s was deleted in version %s of %s%s" what (Version.to_string ver) t.desc + (match repl with + | None -> "" + | Some s -> ".\n" ^ s) end diff --git a/src/syntax.mli b/src/syntax.mli index dd9c8e0b..1baca844 100644 --- a/src/syntax.mli +++ b/src/syntax.mli @@ -25,7 +25,13 @@ module Error : sig val renamed_in : Loc.t -> t -> Version.t -> what:string -> to_:string -> _ - val deleted_in : Loc.t -> t -> Version.t -> what:string -> _ + val deleted_in + : Loc.t + -> t + -> ?repl:string + -> Version.t + -> what:string + -> _ end (** [create ~name ~desc supported_versions] defines a new diff --git a/test/blackbox-tests/test-cases/syntax-versioning/run.t b/test/blackbox-tests/test-cases/syntax-versioning/run.t index 100b0add..40fba033 100644 --- a/test/blackbox-tests/test-cases/syntax-versioning/run.t +++ b/test/blackbox-tests/test-cases/syntax-versioning/run.t @@ -16,3 +16,11 @@ Error: 'link_executables' was deleted in version 1.0 of the dune language [1] $ rm -f dune + + $ echo '(alias (name x) (deps x) (action (run %{<})))' > dune + $ dune build + File "dune", line 1, characters 40-42: + Error: %{<} was deleted in version 1.0 of the dune language. + Use a named dependency instead: (: ) + [1] + $ rm -f dune From 0b1abc68bd3fb2bb333a3d0834bcf03556d1a80e Mon Sep 17 00:00:00 2001 From: Jeremie Dimino Date: Mon, 9 Jul 2018 16:23:09 +0100 Subject: [PATCH 13/34] Improve error message for %{<} Signed-off-by: Jeremie Dimino --- src/pform.ml | 5 ++++- test/blackbox-tests/test-cases/syntax-versioning/run.t | 5 ++++- 2 files changed, 8 insertions(+), 2 deletions(-) diff --git a/src/pform.ml b/src/pform.ml index 587cff57..3b0be7bf 100644 --- a/src/pform.ml +++ b/src/pform.ml @@ -53,7 +53,10 @@ module Map = struct ; "project_root", since ~version:(1, 0) Var.Project_root ; "<", deleted_in Var.Deps ~version:(1, 0) - ~repl:"Use a named dependency instead: (: )" + ~repl:"Use a named dependency instead:\ + \n\ + \n\ (deps (:x ) ...)\ + \n\ ... %{x} ..." ; "@", renamed_in ~version:(1, 0) ~new_name:"targets" ; "^", renamed_in ~version:(1, 0) ~new_name:"deps" ; "SCOPE_ROOT", renamed_in ~version:(1, 0) ~new_name:"project_root" diff --git a/test/blackbox-tests/test-cases/syntax-versioning/run.t b/test/blackbox-tests/test-cases/syntax-versioning/run.t index 40fba033..78725b94 100644 --- a/test/blackbox-tests/test-cases/syntax-versioning/run.t +++ b/test/blackbox-tests/test-cases/syntax-versioning/run.t @@ -21,6 +21,9 @@ $ dune build File "dune", line 1, characters 40-42: Error: %{<} was deleted in version 1.0 of the dune language. - Use a named dependency instead: (: ) + Use a named dependency instead: + + (deps (:x ) ...) + ... %{x} ... [1] $ rm -f dune From bfc1b9fd25c4bf24d3fdd52a1faee28fbcdbea88 Mon Sep 17 00:00:00 2001 From: Rudi Grinberg Date: Mon, 9 Jul 2018 22:26:40 +0700 Subject: [PATCH 14/34] Change binding representation to use a list This preserves the order of things Signed-off-by: Rudi Grinberg --- src/jbuild.ml | 92 +++++++++---------- src/jbuild.mli | 15 +-- src/super_context.ml | 42 +++++---- .../test-cases/merlin-tests/run.t | 24 ++--- test/blackbox-tests/test-cases/misc/run.t | 21 +---- 5 files changed, 94 insertions(+), 100 deletions(-) diff --git a/src/jbuild.ml b/src/jbuild.ml index 2be16d07..54154ffd 100644 --- a/src/jbuild.ml +++ b/src/jbuild.ml @@ -233,31 +233,33 @@ module Pps_and_flags = struct end module Named = struct - type 'a t = - { named: 'a list String.Map.t - ; unnamed : 'a list - } + type 'a one = + | Unnamed of 'a + | Named of string * 'a list - let fold { named; unnamed } ~f ~init = - let flipped x acc = f acc x in - String.Map.fold named - ~f:(fun x init -> List.fold_left ~f:flipped ~init x) - ~init:(List.fold_left ~f:flipped ~init unnamed) + type 'a t = 'a one list - let first { named; unnamed } = - if String.Map.is_empty named then - match unnamed with - | [] -> Result.Error `Empty - | x :: _ -> Ok x - else - Result.Error `Named_exists + let to_list = + List.concat_map ~f:(function + | Unnamed x -> [x] + | Named (_, xs) -> xs) - let empty = - { named = String.Map.empty - ; unnamed = [] - } + let find t k = + List.find_map t ~f:(function + | Unnamed _ -> None + | Named (k', x) -> Option.some_if (k = k') x) - let singleton x = { empty with unnamed = [x] } + let first t = + let rec loop acc = function + | [] -> acc + | Unnamed x :: xs -> loop (Result.Ok x) xs + | Named (_, _) :: _ -> Result.Error `Named_exists + in + loop (Result.Error `Empty) t + + let empty = [] + + let singleton x = [Unnamed x] let t elem = let binding = @@ -267,29 +269,32 @@ module Named = struct let name = String.sub s ~pos:1 ~len:(String.length s - 1) in enter (junk >>= fun () -> repeat elem >>| fun values -> - Left (name, (loc, values))) + Left (loc, name, values)) | _ -> elem >>| fun elem -> Right elem in list binding >>| (fun bindings -> - let (named, unnamed) = List.partition_map bindings ~f:(fun x -> x) in - { unnamed - ; named = - (match String.Map.of_list named with - | Ok x -> x - | Error (name, (l1, _), (l2, _)) -> - of_sexp_errorf l1 "Variable %s is already defined in %s" - name (Loc.to_file_colon_line l2)) - |> String.Map.map ~f:snd - }) + let used_names = Hashtbl.create 8 in + List.fold_right bindings ~init:[] ~f:(fun x acc -> + match x with + | Right x -> Unnamed x :: acc + | Left (loc, name, values) -> + begin match Hashtbl.find used_names name with + | None -> + Hashtbl.add used_names name loc; + Named (name, values) :: acc + | Some loc_old -> + of_sexp_errorf loc "Variable %s is already defined in %s" + name (Loc.to_file_colon_line loc_old) + end)) - let sexp_of_t sexp_of_a { unnamed; named } = - let unnamed = List.map ~f:sexp_of_a unnamed in - let named = - String.Map.foldi ~init:[] named ~f:(fun n d acc -> - Sexp.unsafe_atom_of_string (":" ^ n) :: (List.map ~f:sexp_of_a d) @ acc) - in - Sexp.List (unnamed @ named) + let sexp_of_t sexp_of_a bindings = + Sexp.List ( + List.map bindings ~f:(function + | Unnamed a -> sexp_of_a a + | Named (name, bindings) -> + Sexp.List (Sexp.atom (":" ^ name) :: List.map ~f:sexp_of_a bindings)) + ) end module Dep_conf = struct @@ -1296,9 +1301,7 @@ module Rule = struct let src = name ^ ".mll" in let dst = name ^ ".ml" in { targets = Static [dst] - ; deps = { Named.empty with - unnamed = [File (S.virt_text __POS__ src)] - } + ; deps = Named.singleton (Dep_conf.File (S.virt_text __POS__ src)) ; action = (loc, Chdir @@ -1319,10 +1322,7 @@ module Rule = struct List.map modules ~f:(fun name -> let src = name ^ ".mly" in { targets = Static [name ^ ".ml"; name ^ ".mli"] - ; deps = - { Named.empty with - unnamed = [File (S.virt_text __POS__ src)] - } + ; deps = Named.singleton (Dep_conf.File (S.virt_text __POS__ src)) ; action = (loc, Chdir diff --git a/src/jbuild.mli b/src/jbuild.mli index 8b9e3979..6d2cfa20 100644 --- a/src/jbuild.mli +++ b/src/jbuild.mli @@ -82,19 +82,22 @@ module Lib_deps : sig end module Named : sig - type 'a t = - { named : 'a list String.Map.t - ; unnamed : 'a list - } + type 'a one = + | Unnamed of 'a + | Named of string * 'a list + + type 'a t = 'a one list + + val find : 'a t -> string -> 'a list option val empty : 'a t + val to_list : 'a t -> 'a list + val singleton : 'a -> 'a t val first : 'a t -> ('a, [`Empty | `Named_exists]) Result.t - val fold : 'a t -> f:('a -> 'init -> 'init) -> init:'init -> 'init - val sexp_of_t : ('a -> Usexp.t) -> 'a t -> Usexp.t end diff --git a/src/super_context.ml b/src/super_context.ml index dd024ebf..9306c2f4 100644 --- a/src/super_context.ml +++ b/src/super_context.ml @@ -527,21 +527,29 @@ module Deps = struct |> Build.all >>^ List.concat - let interpret_named t ~scope ~dir { Named.unnamed; named } = - let deps l = - List.map ~f:(dep t ~scope ~dir) l - |> Build.all - >>^ List.concat - in - let unnamed = deps unnamed in - let named = - String.Map.to_list named - |> List.map ~f:(fun (k, d) -> deps d >>^ fun d -> (k, d)) - |> Build.all - >>^ String.Map.of_list_exn - in - unnamed &&& named >>^ fun (unnamed, named) -> - { Named.unnamed; named } + let interpret_named t ~scope ~dir bindings = + let unnamed x = Jbuild.Named.Unnamed x in + List.map bindings ~f:(function + | Jbuild.Named.Unnamed p -> + dep t ~scope ~dir p >>^ unnamed + | Named (s, ps) -> + List.map ~f:(dep t ~scope ~dir) ps + |> Build.all + >>^ (fun deps -> Jbuild.Named.Named (s, deps))) + |> Build.all + >>^ List.concat_map ~f:(function + | Jbuild.Named.Unnamed s -> List.map s ~f:unnamed + | Named (s, ps) -> [Named (s, List.concat ps)]) + + (* let unnamed = deps (Jbuild.Named.unnamed bindings) in + * let named = + * String.Map.to_list named + * |> List.map ~f:(fun (k, d) -> deps d >>^ fun d -> (k, d)) + * |> Build.all + * >>^ String.Map.of_list_exn + * in + * unnamed &&& named >>^ fun (unnamed, named) -> + * { Named.unnamed; named } *) end module Pkg_version = struct @@ -784,13 +792,13 @@ module Action = struct Pform.Map.expand Pform.Map.static_vars ~syntax_version ~var with | None -> - String.Map.find deps_written_by_user.named key + Jbuild.Named.find deps_written_by_user key |> Option.map ~f:Value.L.paths | Some x -> begin match x with Pform.Var.Deps -> deps_written_by_user - |> Jbuild.Named.fold ~init:[] ~f:List.cons + |> Jbuild.Named.to_list |> Value.L.paths |> Option.some | First_dep -> diff --git a/test/blackbox-tests/test-cases/merlin-tests/run.t b/test/blackbox-tests/test-cases/merlin-tests/run.t index b1659de9..91b53db1 100644 --- a/test/blackbox-tests/test-cases/merlin-tests/run.t +++ b/test/blackbox-tests/test-cases/merlin-tests/run.t @@ -4,18 +4,6 @@ ocamlopt sanitize-dot-merlin/.sanitize_dot_merlin.eobjs/sanitize_dot_merlin.{cmx,o} ocamlopt sanitize-dot-merlin/sanitize_dot_merlin.exe sanitize_dot_merlin alias print-merlins - # Processing lib/.merlin - B $LIB_PREFIX/lib/bytes - B $LIB_PREFIX/lib/findlib - B $LIB_PREFIX/lib/ocaml - B ../_build/default/lib/.bar.objs - B ../_build/default/lib/.foo.objs - S $LIB_PREFIX/lib/bytes - S $LIB_PREFIX/lib/findlib - S $LIB_PREFIX/lib/ocaml - S . - FLG -ppx '$PPX/fooppx@./ppx.exe --as-ppx --cookie '\''library-name="foo"'\''' - FLG -open Foo -w -40 -open Bar -w -40 # Processing exe/.merlin B $LIB_PREFIX/lib/bytes B $LIB_PREFIX/lib/findlib @@ -28,6 +16,18 @@ S . S ../lib FLG -w -40 + # Processing lib/.merlin + B $LIB_PREFIX/lib/bytes + B $LIB_PREFIX/lib/findlib + B $LIB_PREFIX/lib/ocaml + B ../_build/default/lib/.bar.objs + B ../_build/default/lib/.foo.objs + S $LIB_PREFIX/lib/bytes + S $LIB_PREFIX/lib/findlib + S $LIB_PREFIX/lib/ocaml + S . + FLG -ppx '$PPX/fooppx@./ppx.exe --as-ppx --cookie '\''library-name="foo"'\''' + FLG -open Foo -w -40 -open Bar -w -40 Make sure a ppx directive is generated diff --git a/test/blackbox-tests/test-cases/misc/run.t b/test/blackbox-tests/test-cases/misc/run.t index b0a157f5..4b02d83e 100644 --- a/test/blackbox-tests/test-cases/misc/run.t +++ b/test/blackbox-tests/test-cases/misc/run.t @@ -2,22 +2,5 @@ File "dune", line 44, characters 19-42: Warning: Directory dir-that-doesnt-exist doesn't exist. diff alias runtest - diff alias runtest (exit 1) - (cd _build/default && /usr/bin/diff -u result expected) - --- result 2018-07-09 16:03:03.123914026 +0100 - +++ expected 2018-07-09 16:03:03.124914029 +0100 - @@ -1 +1 @@ - -c.txt b.txt a.txt dune - \ No newline at end of file - +dune a.txt b.txt c.txt - \ No newline at end of file - diff alias runtest (exit 1) - (cd _build/default && /usr/bin/diff -u result2 expected2) - --- result2 2018-07-09 16:03:03.124914029 +0100 - +++ expected2 2018-07-09 16:03:03.124914029 +0100 - @@ -1 +1 @@ - -sub-tree/dir/b sub-tree/a - \ No newline at end of file - +sub-tree/a sub-tree/dir/b - \ No newline at end of file - [1] + diff alias runtest + diff alias runtest From 65e1aa004333edf63a4e7dcbbfd8616d77ec38b0 Mon Sep 17 00:00:00 2001 From: Rudi Grinberg Date: Mon, 9 Jul 2018 22:32:43 +0700 Subject: [PATCH 15/34] Rename Jbuild.Named to Jbuild.Bindings Signed-off-by: Rudi Grinberg --- src/gen_rules.ml | 4 ++-- src/inline_tests.ml | 2 +- src/jbuild.ml | 21 +++++++++++---------- src/jbuild.mli | 8 ++++---- src/preprocessing.ml | 4 ++-- src/super_context.ml | 28 +++++++++------------------- src/super_context.mli | 6 +++--- 7 files changed, 32 insertions(+), 41 deletions(-) diff --git a/src/gen_rules.ml b/src/gen_rules.ml index 97e0a4a6..7f88c6a2 100644 --- a/src/gen_rules.ml +++ b/src/gen_rules.ml @@ -929,7 +929,7 @@ module Gen(P : Install_rules.Params) = struct let module S = Sexp.To_sexp in Sexp.List [ Sexp.unsafe_atom_of_string "user-alias" - ; Jbuild.Named.sexp_of_t Jbuild.Dep_conf.sexp_of_t alias_conf.deps + ; Jbuild.Bindings.sexp_of_t Jbuild.Dep_conf.sexp_of_t alias_conf.deps ; S.option Action.Unexpanded.sexp_of_t (Option.map alias_conf.action ~f:snd) ] @@ -976,7 +976,7 @@ module Gen(P : Install_rules.Params) = struct let rule = { Rule. targets = Infer - ; deps = Named.empty + ; deps = Bindings.empty ; action = (loc, Action.Unexpanded.Redirect (Stdout, diff.file2, run_action)) ; mode = Standard diff --git a/src/inline_tests.ml b/src/inline_tests.ml index 16296a12..b62d638c 100644 --- a/src/inline_tests.ml +++ b/src/inline_tests.ml @@ -214,7 +214,7 @@ include Sub_system.Register_end_point( ~init:extra_vars ~f:(fun acc (k, v) -> String.Map.add acc k v) in - Build.return Named.empty + Build.return Bindings.empty >>> Build.all (List.filter_map backends ~f:(fun (backend : Backend.t) -> diff --git a/src/jbuild.ml b/src/jbuild.ml index 54154ffd..7fb9c9cd 100644 --- a/src/jbuild.ml +++ b/src/jbuild.ml @@ -232,7 +232,7 @@ module Pps_and_flags = struct Dune_syntax.t end -module Named = struct +module Bindings = struct type 'a one = | Unnamed of 'a | Named of string * 'a list @@ -1140,7 +1140,7 @@ module Rule = struct type t = { targets : Targets.t - ; deps : Dep_conf.t Named.t + ; deps : Dep_conf.t Bindings.t ; action : Loc.t * Action.Unexpanded.t ; mode : Mode.t ; locks : String_with_vars.t list @@ -1182,7 +1182,7 @@ module Rule = struct let short_form = located Action.Unexpanded.t >>| fun (loc, action) -> { targets = Infer - ; deps = Named.empty + ; deps = Bindings.empty ; action = (loc, action) ; mode = Standard ; locks = [] @@ -1195,7 +1195,7 @@ module Rule = struct >>= fun action -> field "targets" (list file_in_current_dir) >>= fun targets -> - field "deps" (Named.t Dep_conf.t) ~default:Named.empty + field "deps" (Bindings.t Dep_conf.t) ~default:Bindings.empty >>= fun deps -> field "locks" (list String_with_vars.t) ~default:[] >>= fun locks -> map_validate @@ -1301,7 +1301,7 @@ module Rule = struct let src = name ^ ".mll" in let dst = name ^ ".ml" in { targets = Static [dst] - ; deps = Named.singleton (Dep_conf.File (S.virt_text __POS__ src)) + ; deps = Bindings.singleton (Dep_conf.File (S.virt_text __POS__ src)) ; action = (loc, Chdir @@ -1322,7 +1322,7 @@ module Rule = struct List.map modules ~f:(fun name -> let src = name ^ ".mly" in { targets = Static [name ^ ".ml"; name ^ ".mli"] - ; deps = Named.singleton (Dep_conf.File (S.virt_text __POS__ src)) + ; deps = Bindings.singleton (Dep_conf.File (S.virt_text __POS__ src)) ; action = (loc, Chdir @@ -1390,7 +1390,7 @@ end module Alias_conf = struct type t = { name : string - ; deps : Dep_conf.t Named.t + ; deps : Dep_conf.t Bindings.t ; action : (Loc.t * Action.Unexpanded.t) option ; locks : String_with_vars.t list ; package : Package.t option @@ -1409,7 +1409,7 @@ module Alias_conf = struct field_o "package" Pkg.t >>= fun package -> field_o "action" (located Action.Unexpanded.t) >>= fun action -> field "locks" (list String_with_vars.t) ~default:[] >>= fun locks -> - field "deps" (Named.t Dep_conf.t) ~default:Named.empty + field "deps" (Bindings.t Dep_conf.t) ~default:Bindings.empty >>= fun deps -> return { name @@ -1425,7 +1425,7 @@ module Tests = struct { exes : Executables.t ; locks : String_with_vars.t list ; package : Package.t option - ; deps : Dep_conf.t Named.t + ; deps : Dep_conf.t Bindings.t } let gen_parse names = @@ -1433,11 +1433,12 @@ module Tests = struct (Buildable.t >>= fun buildable -> field_oslu "link_flags" >>= fun link_flags -> names >>= fun names -> - field "deps" (Named.t Dep_conf.t) ~default:Named.empty >>= fun deps -> field_o "package" Pkg.t >>= fun package -> field "locks" (list String_with_vars.t) ~default:[] >>= fun locks -> field "modes" Executables.Link_mode.Set.t ~default:Executables.Link_mode.Set.default >>= fun modes -> + field "deps" (Bindings.t Dep_conf.t) ~default:Bindings.empty + >>= fun deps -> return { exes = { Executables. diff --git a/src/jbuild.mli b/src/jbuild.mli index 6d2cfa20..c9871a5f 100644 --- a/src/jbuild.mli +++ b/src/jbuild.mli @@ -81,7 +81,7 @@ module Lib_deps : sig val of_pps : Pp.t list -> t end -module Named : sig +module Bindings : sig type 'a one = | Unnamed of 'a | Named of string * 'a list @@ -304,7 +304,7 @@ module Rule : sig type t = { targets : Targets.t - ; deps : Dep_conf.t Named.t + ; deps : Dep_conf.t Bindings.t ; action : Loc.t * Action.Unexpanded.t ; mode : Mode.t ; locks : String_with_vars.t list @@ -327,7 +327,7 @@ end module Alias_conf : sig type t = { name : string - ; deps : Dep_conf.t Named.t + ; deps : Dep_conf.t Bindings.t ; action : (Loc.t * Action.Unexpanded.t) option ; locks : String_with_vars.t list ; package : Package.t option @@ -370,7 +370,7 @@ module Tests : sig { exes : Executables.t ; locks : String_with_vars.t list ; package : Package.t option - ; deps : Dep_conf.t Named.t + ; deps : Dep_conf.t Bindings.t } end diff --git a/src/preprocessing.ml b/src/preprocessing.ml index 799c8926..6179e412 100644 --- a/src/preprocessing.ml +++ b/src/preprocessing.ml @@ -456,7 +456,7 @@ let lint_module sctx ~dir ~dep_kind ~lint ~lib_name ~scope ~dir_kind = let src_path = Path.relative dir src.name in add_alias src.name (Build.path src_path - >>^ (fun _ -> Jbuild.Named.singleton src_path) + >>^ (fun _ -> Jbuild.Bindings.singleton src_path) >>> SC.Action.run sctx action ~loc @@ -531,7 +531,7 @@ let make sctx ~dir ~dep_kind ~lint ~preprocess (preprocessor_deps >>> Build.path src - >>^ (fun _ -> Jbuild.Named.singleton src) + >>^ (fun _ -> Jbuild.Bindings.singleton src) >>> SC.Action.run sctx (Redirect diff --git a/src/super_context.ml b/src/super_context.ml index 9306c2f4..7c4b629b 100644 --- a/src/super_context.ml +++ b/src/super_context.ml @@ -528,28 +528,18 @@ module Deps = struct >>^ List.concat let interpret_named t ~scope ~dir bindings = - let unnamed x = Jbuild.Named.Unnamed x in + let unnamed x = Jbuild.Bindings.Unnamed x in List.map bindings ~f:(function - | Jbuild.Named.Unnamed p -> + | Jbuild.Bindings.Unnamed p -> dep t ~scope ~dir p >>^ unnamed | Named (s, ps) -> List.map ~f:(dep t ~scope ~dir) ps |> Build.all - >>^ (fun deps -> Jbuild.Named.Named (s, deps))) + >>^ (fun deps -> Jbuild.Bindings.Named (s, deps))) |> Build.all >>^ List.concat_map ~f:(function - | Jbuild.Named.Unnamed s -> List.map s ~f:unnamed + | Jbuild.Bindings.Unnamed s -> List.map s ~f:unnamed | Named (s, ps) -> [Named (s, List.concat ps)]) - - (* let unnamed = deps (Jbuild.Named.unnamed bindings) in - * let named = - * String.Map.to_list named - * |> List.map ~f:(fun (k, d) -> deps d >>^ fun d -> (k, d)) - * |> Build.all - * >>^ String.Map.of_list_exn - * in - * unnamed &&& named >>^ fun (unnamed, named) -> - * { Named.unnamed; named } *) end module Pkg_version = struct @@ -780,7 +770,7 @@ module Action = struct (t, acc) let expand_step2 ~dir ~dynamic_expansions - ~(deps_written_by_user : Path.t Jbuild.Named.t) + ~(deps_written_by_user : Path.t Jbuild.Bindings.t) ~map_exe t = U.Partial.expand t ~dir ~map_exe ~f:(fun var syntax_version -> let key = String_with_vars.Var.full_name var in @@ -792,17 +782,17 @@ module Action = struct Pform.Map.expand Pform.Map.static_vars ~syntax_version ~var with | None -> - Jbuild.Named.find deps_written_by_user key + Jbuild.Bindings.find deps_written_by_user key |> Option.map ~f:Value.L.paths | Some x -> begin match x with Pform.Var.Deps -> deps_written_by_user - |> Jbuild.Named.to_list + |> Jbuild.Bindings.to_list |> Value.L.paths |> Option.some | First_dep -> - begin match Jbuild.Named.first deps_written_by_user with + begin match Jbuild.Bindings.first deps_written_by_user with | Error `Named_exists -> Loc.fail loc "%%{first-dep} is not allowed with named dependencies" | Error `Empty -> @@ -819,7 +809,7 @@ module Action = struct let run sctx ~loc ?(extra_vars=String.Map.empty) t ~dir ~dep_kind ~targets:targets_written_by_user ~scope - : (Path.t Named.t, Action.t) Build.t = + : (Path.t Bindings.t, Action.t) Build.t = let map_exe = map_exe sctx in if targets_written_by_user = Alias then begin match Action.Infer.unexpanded_targets t with diff --git a/src/super_context.mli b/src/super_context.mli index f7ba8137..7e318771 100644 --- a/src/super_context.mli +++ b/src/super_context.mli @@ -224,8 +224,8 @@ module Deps : sig : t -> scope:Scope.t -> dir:Path.t - -> Dep_conf.t Named.t - -> (unit, Path.t Named.t) Build.t + -> Dep_conf.t Bindings.t + -> (unit, Path.t Bindings.t) Build.t end (** Interpret action written in jbuild files *) @@ -245,7 +245,7 @@ module Action : sig -> dep_kind:Build.lib_dep_kind -> targets:targets -> scope:Scope.t - -> (Path.t Named.t, Action.t) Build.t + -> (Path.t Bindings.t, Action.t) Build.t end module Pkg_version : sig From 205d12755ed0835db4de9af9485ae08422133b52 Mon Sep 17 00:00:00 2001 From: Rudi Grinberg Date: Mon, 9 Jul 2018 22:36:21 +0700 Subject: [PATCH 16/34] Failing test for shadowing bindings Signed-off-by: Rudi Grinberg --- test/blackbox-tests/dune.inc | 10 ++++++++++ test/blackbox-tests/test-cases/shadow-bindings/dune | 5 +++++ .../test-cases/shadow-bindings/dune-project | 1 + test/blackbox-tests/test-cases/shadow-bindings/foo | 0 test/blackbox-tests/test-cases/shadow-bindings/run.t | 4 ++++ 5 files changed, 20 insertions(+) create mode 100644 test/blackbox-tests/test-cases/shadow-bindings/dune create mode 100644 test/blackbox-tests/test-cases/shadow-bindings/dune-project create mode 100644 test/blackbox-tests/test-cases/shadow-bindings/foo create mode 100644 test/blackbox-tests/test-cases/shadow-bindings/run.t diff --git a/test/blackbox-tests/dune.inc b/test/blackbox-tests/dune.inc index 72e2921f..b845770c 100644 --- a/test/blackbox-tests/dune.inc +++ b/test/blackbox-tests/dune.inc @@ -611,6 +611,14 @@ test-cases/select (progn (run %{exe:cram.exe} -test run.t) (diff? run.t run.t.corrected))))) +(alias + (name shadow-bindings) + (deps (package dune) (source_tree test-cases/shadow-bindings)) + (action + (chdir + test-cases/shadow-bindings + (progn (run %{exe:cram.exe} -test run.t) (diff? run.t run.t.corrected))))) + (alias (name subst) (deps (package dune) (source_tree test-cases/subst)) @@ -749,6 +757,7 @@ (alias scope-bug) (alias scope-ppx-bug) (alias select) + (alias shadow-bindings) (alias subst) (alias syntax-versioning) (alias tests-stanza) @@ -824,6 +833,7 @@ (alias scope-bug) (alias scope-ppx-bug) (alias select) + (alias shadow-bindings) (alias subst) (alias syntax-versioning) (alias tests-stanza) diff --git a/test/blackbox-tests/test-cases/shadow-bindings/dune b/test/blackbox-tests/test-cases/shadow-bindings/dune new file mode 100644 index 00000000..68875f23 --- /dev/null +++ b/test/blackbox-tests/test-cases/shadow-bindings/dune @@ -0,0 +1,5 @@ + +(alias + (name runtest) + (deps (:root foo)) + (action (echo %{root}))) \ No newline at end of file diff --git a/test/blackbox-tests/test-cases/shadow-bindings/dune-project b/test/blackbox-tests/test-cases/shadow-bindings/dune-project new file mode 100644 index 00000000..b2559fa0 --- /dev/null +++ b/test/blackbox-tests/test-cases/shadow-bindings/dune-project @@ -0,0 +1 @@ +(lang dune 1.0) \ No newline at end of file diff --git a/test/blackbox-tests/test-cases/shadow-bindings/foo b/test/blackbox-tests/test-cases/shadow-bindings/foo new file mode 100644 index 00000000..e69de29b diff --git a/test/blackbox-tests/test-cases/shadow-bindings/run.t b/test/blackbox-tests/test-cases/shadow-bindings/run.t new file mode 100644 index 00000000..565385e9 --- /dev/null +++ b/test/blackbox-tests/test-cases/shadow-bindings/run.t @@ -0,0 +1,4 @@ +Bindings introduced by user dependencies should shadow existing bindings + + $ dune runtest + . From 17d4a7c3dfc1b6fadcb94db86bda2b5549fa4873 Mon Sep 17 00:00:00 2001 From: Jeremie Dimino Date: Mon, 9 Jul 2018 16:43:10 +0100 Subject: [PATCH 17/34] Refactor a bit the parsing code for bindings Signed-off-by: Jeremie Dimino --- src/jbuild.ml | 40 +++++++++++++++++++--------------------- 1 file changed, 19 insertions(+), 21 deletions(-) diff --git a/src/jbuild.ml b/src/jbuild.ml index 7fb9c9cd..f6b3a9e6 100644 --- a/src/jbuild.ml +++ b/src/jbuild.ml @@ -262,31 +262,29 @@ module Bindings = struct let singleton x = [Unnamed x] let t elem = - let binding = - peek_exn >>= function - | List (_, Atom (loc, A s) :: _) when + let rec loop vars acc = + peek >>= function + | None -> return (List.rev acc) + | Some (List (_, Atom (loc, A s) :: _)) when String.length s > 1 && s.[0] = ':' -> let name = String.sub s ~pos:1 ~len:(String.length s - 1) in - enter (junk >>= fun () -> - repeat elem >>| fun values -> - Left (loc, name, values)) + let vars = + if not (String.Set.mem vars name) then + String.Set.add vars name + else + of_sexp_errorf loc "Variable %s is defined for the second time." + name + in + enter (junk >>= fun () -> repeat elem) + >>= fun values -> + loop vars (Named (name, values) :: acc) | _ -> - elem >>| fun elem -> Right elem + elem >>= fun x -> + loop vars (Unnamed x :: acc) in - list binding >>| (fun bindings -> - let used_names = Hashtbl.create 8 in - List.fold_right bindings ~init:[] ~f:(fun x acc -> - match x with - | Right x -> Unnamed x :: acc - | Left (loc, name, values) -> - begin match Hashtbl.find used_names name with - | None -> - Hashtbl.add used_names name loc; - Named (name, values) :: acc - | Some loc_old -> - of_sexp_errorf loc "Variable %s is already defined in %s" - name (Loc.to_file_colon_line loc_old) - end)) + Stanza.file_kind () >>= function + | Jbuild -> list (elem >>| fun x -> Unnamed x) + | Dune -> loop String.Set.empty [] let sexp_of_t sexp_of_a bindings = Sexp.List ( From 015b317f437bc634eaaff27c1a79bc680250d267 Mon Sep 17 00:00:00 2001 From: Rudi Grinberg Date: Mon, 9 Jul 2018 23:14:36 +0700 Subject: [PATCH 18/34] Introduce a bindings variable for actions We need to know the bindings statically whenever they overwrite existing vars Signed-off-by: Rudi Grinberg --- src/gen_rules.ml | 2 ++ src/inline_tests.ml | 1 + src/jbuild.ml | 2 ++ src/jbuild.mli | 2 ++ src/pform.ml | 13 +++++++++++++ src/pform.mli | 7 +++++++ src/preprocessing.ml | 2 ++ src/super_context.ml | 3 ++- src/super_context.mli | 1 + 9 files changed, 32 insertions(+), 1 deletion(-) diff --git a/src/gen_rules.ml b/src/gen_rules.ml index 7f88c6a2..467d4f54 100644 --- a/src/gen_rules.ml +++ b/src/gen_rules.ml @@ -194,6 +194,7 @@ module Gen(P : Install_rules.Params) = struct (snd rule.action) ~loc:(fst rule.action) ~dir + ~bindings:(Pform.Map.of_bindings rule.deps) ~dep_kind:Required ~targets ~scope) @@ -950,6 +951,7 @@ module Gen(P : Install_rules.Params) = struct ~loc ~dir ~dep_kind:Required + ~bindings:(Pform.Map.of_bindings alias_conf.deps) ~targets:Alias ~scope) diff --git a/src/inline_tests.ml b/src/inline_tests.ml index b62d638c..4e7522a1 100644 --- a/src/inline_tests.ml +++ b/src/inline_tests.ml @@ -220,6 +220,7 @@ include Sub_system.Register_end_point( (List.filter_map backends ~f:(fun (backend : Backend.t) -> Option.map backend.info.generate_runner ~f:(fun (loc, action) -> SC.Action.run sctx action ~loc + ~bindings:Pform.Map.empty ~extra_vars ~dir ~dep_kind:Required ~targets:Alias ~scope))) >>^ (fun actions -> Action.with_stdout_to target diff --git a/src/jbuild.ml b/src/jbuild.ml index f6b3a9e6..8a36823a 100644 --- a/src/jbuild.ml +++ b/src/jbuild.ml @@ -239,6 +239,8 @@ module Bindings = struct type 'a t = 'a one list + let fold t ~f ~init = List.fold_left ~f:(fun acc x -> f x acc) ~init t + let to_list = List.concat_map ~f:(function | Unnamed x -> [x] diff --git a/src/jbuild.mli b/src/jbuild.mli index c9871a5f..2b796925 100644 --- a/src/jbuild.mli +++ b/src/jbuild.mli @@ -90,6 +90,8 @@ module Bindings : sig val find : 'a t -> string -> 'a list option + val fold : 'a t -> f:('a one -> 'acc -> 'acc) -> init:'acc -> 'acc + val empty : 'a t val to_list : 'a t -> 'a list diff --git a/src/pform.ml b/src/pform.ml index 3b0be7bf..f2f96eec 100644 --- a/src/pform.ml +++ b/src/pform.ml @@ -7,6 +7,7 @@ module Var = struct | First_dep | Deps | Targets + | Named_local let to_value_no_deps_or_targets t ~scope = match t with @@ -14,6 +15,7 @@ module Var = struct | Project_root -> Some [Value.Dir (Scope.root scope)] | First_dep | Deps + | Named_local | Targets -> None end @@ -141,6 +143,8 @@ module Map = struct let static_vars = String.Map.of_list_exn static_vars + let superpose = String.Map.superpose + let rec expand t ~syntax_version ~var = let name = String_with_vars.Var.name var in Option.bind (String.Map.find t name) ~f:(fun v -> @@ -176,4 +180,13 @@ module Map = struct else Syntax.Error.deleted_in (String_with_vars.Var.loc var) Stanza.syntax syntax_version ~what:(what var) ?repl) + + let empty = String.Map.empty + + let of_bindings = + Jbuild.Bindings.fold ~f:(fun x acc -> + match x with + | Unnamed _ -> acc + | Named (s, _) -> String.Map.add acc s (No_info Var.Named_local) + ) ~init:empty end diff --git a/src/pform.mli b/src/pform.mli index 71ab99ae..9e1149a8 100644 --- a/src/pform.mli +++ b/src/pform.mli @@ -5,6 +5,7 @@ module Var : sig | First_dep | Deps | Targets + | Named_local val to_value_no_deps_or_targets : t -> scope:Scope.t -> Value.t list option end @@ -41,9 +42,15 @@ module Map : sig val static_vars : Var.t t + val superpose : 'a t -> 'a t -> 'a t + + val of_bindings : 'a Jbuild.Bindings.t -> Var.t t + val expand : 'a t -> syntax_version:Syntax.Version.t -> var:String_with_vars.Var.t -> 'a option + + val empty : 'a t end with type 'a var := 'a t diff --git a/src/preprocessing.ml b/src/preprocessing.ml index 6179e412..d7584716 100644 --- a/src/preprocessing.ml +++ b/src/preprocessing.ml @@ -462,6 +462,7 @@ let lint_module sctx ~dir ~dep_kind ~lint ~lib_name ~scope ~dir_kind = ~loc ~dir ~dep_kind + ~bindings:Pform.Map.empty ~targets:(Static []) ~scope))) | Pps { loc; pps; flags } -> @@ -542,6 +543,7 @@ let make sctx ~dir ~dep_kind ~lint ~preprocess ~loc ~dir ~dep_kind + ~bindings:Pform.Map.empty ~targets:(Static [dst]) ~scope)) |> setup_reason_rules sctx ~dir in diff --git a/src/super_context.ml b/src/super_context.ml index 7c4b629b..37da70f2 100644 --- a/src/super_context.ml +++ b/src/super_context.ml @@ -807,9 +807,10 @@ module Action = struct end end) - let run sctx ~loc ?(extra_vars=String.Map.empty) + let run sctx ~loc ?(extra_vars=String.Map.empty) ~bindings t ~dir ~dep_kind ~targets:targets_written_by_user ~scope : (Path.t Bindings.t, Action.t) Build.t = + ignore bindings; let map_exe = map_exe sctx in if targets_written_by_user = Alias then begin match Action.Infer.unexpanded_targets t with diff --git a/src/super_context.mli b/src/super_context.mli index 7e318771..f203db79 100644 --- a/src/super_context.mli +++ b/src/super_context.mli @@ -240,6 +240,7 @@ module Action : sig : t -> loc:Loc.t -> ?extra_vars:Value.t list String.Map.t + -> bindings:Pform.Var.t Pform.Map.t -> Action.Unexpanded.t -> dir:Path.t -> dep_kind:Build.lib_dep_kind From fa0ab5b4a474d922f4304ae924e975c0c51cae74 Mon Sep 17 00:00:00 2001 From: Jeremie Dimino Date: Mon, 9 Jul 2018 17:17:49 +0100 Subject: [PATCH 19/34] Add a test with (preprocess (action ...)) Signed-off-by: Jeremie Dimino --- test/blackbox-tests/dune.inc | 10 ++++++++++ .../test-cases/preprocess-with-action/dune-project | 1 + .../test-cases/preprocess-with-action/dune/dune | 3 +++ .../preprocess-with-action/dune/test.expected | 1 + .../test-cases/preprocess-with-action/dune/test.ml | 1 + .../test-cases/preprocess-with-action/jbuild/jbuild | 10 ++++++++++ .../preprocess-with-action/jbuild/test.expected | 1 + .../test-cases/preprocess-with-action/jbuild/test.ml | 1 + .../test-cases/preprocess-with-action/pp/dune | 4 ++++ .../test-cases/preprocess-with-action/pp/pp.mll | 10 ++++++++++ .../test-cases/preprocess-with-action/run.t | 4 ++++ 11 files changed, 46 insertions(+) create mode 100644 test/blackbox-tests/test-cases/preprocess-with-action/dune-project create mode 100644 test/blackbox-tests/test-cases/preprocess-with-action/dune/dune create mode 100644 test/blackbox-tests/test-cases/preprocess-with-action/dune/test.expected create mode 100644 test/blackbox-tests/test-cases/preprocess-with-action/dune/test.ml create mode 100644 test/blackbox-tests/test-cases/preprocess-with-action/jbuild/jbuild create mode 100644 test/blackbox-tests/test-cases/preprocess-with-action/jbuild/test.expected create mode 100644 test/blackbox-tests/test-cases/preprocess-with-action/jbuild/test.ml create mode 100644 test/blackbox-tests/test-cases/preprocess-with-action/pp/dune create mode 100644 test/blackbox-tests/test-cases/preprocess-with-action/pp/pp.mll create mode 100644 test/blackbox-tests/test-cases/preprocess-with-action/run.t diff --git a/test/blackbox-tests/dune.inc b/test/blackbox-tests/dune.inc index b845770c..5d9eb974 100644 --- a/test/blackbox-tests/dune.inc +++ b/test/blackbox-tests/dune.inc @@ -539,6 +539,14 @@ (run %{exe:cram.exe} -skip-versions 4.02.3 -test run.t) (diff? run.t run.t.corrected))))) +(alias + (name preprocess-with-action) + (deps (package dune) (source_tree test-cases/preprocess-with-action)) + (action + (chdir + test-cases/preprocess-with-action + (progn (run %{exe:cram.exe} -test run.t) (diff? run.t run.t.corrected))))) + (alias (name private-public-overlap) (deps (package dune) (source_tree test-cases/private-public-overlap)) @@ -749,6 +757,7 @@ (alias package-dep) (alias path-variables) (alias ppx-rewriter) + (alias preprocess-with-action) (alias private-public-overlap) (alias project-root) (alias promote) @@ -826,6 +835,7 @@ (alias output-obj) (alias package-dep) (alias path-variables) + (alias preprocess-with-action) (alias project-root) (alias promote) (alias quoting) diff --git a/test/blackbox-tests/test-cases/preprocess-with-action/dune-project b/test/blackbox-tests/test-cases/preprocess-with-action/dune-project new file mode 100644 index 00000000..de4fc209 --- /dev/null +++ b/test/blackbox-tests/test-cases/preprocess-with-action/dune-project @@ -0,0 +1 @@ +(lang dune 1.0) diff --git a/test/blackbox-tests/test-cases/preprocess-with-action/dune/dune b/test/blackbox-tests/test-cases/preprocess-with-action/dune/dune new file mode 100644 index 00000000..e0af31fc --- /dev/null +++ b/test/blackbox-tests/test-cases/preprocess-with-action/dune/dune @@ -0,0 +1,3 @@ +(test + (name test) + (preprocess (action (run pp/pp.exe %{first-dep})))) diff --git a/test/blackbox-tests/test-cases/preprocess-with-action/dune/test.expected b/test/blackbox-tests/test-cases/preprocess-with-action/dune/test.expected new file mode 100644 index 00000000..af5626b4 --- /dev/null +++ b/test/blackbox-tests/test-cases/preprocess-with-action/dune/test.expected @@ -0,0 +1 @@ +Hello, world! diff --git a/test/blackbox-tests/test-cases/preprocess-with-action/dune/test.ml b/test/blackbox-tests/test-cases/preprocess-with-action/dune/test.ml new file mode 100644 index 00000000..cec6d9fa --- /dev/null +++ b/test/blackbox-tests/test-cases/preprocess-with-action/dune/test.ml @@ -0,0 +1 @@ +print_endline _STRING_ diff --git a/test/blackbox-tests/test-cases/preprocess-with-action/jbuild/jbuild b/test/blackbox-tests/test-cases/preprocess-with-action/jbuild/jbuild new file mode 100644 index 00000000..05cb6c41 --- /dev/null +++ b/test/blackbox-tests/test-cases/preprocess-with-action/jbuild/jbuild @@ -0,0 +1,10 @@ +(executable + ((name test) + (preprocess (action (run pp/pp.exe ${<}))))) + +(rule + (with-stdout-to test.output (run ./test.exe))) + +(alias + ((name runtest) + (action (diff test.expected test.output)))) diff --git a/test/blackbox-tests/test-cases/preprocess-with-action/jbuild/test.expected b/test/blackbox-tests/test-cases/preprocess-with-action/jbuild/test.expected new file mode 100644 index 00000000..af5626b4 --- /dev/null +++ b/test/blackbox-tests/test-cases/preprocess-with-action/jbuild/test.expected @@ -0,0 +1 @@ +Hello, world! diff --git a/test/blackbox-tests/test-cases/preprocess-with-action/jbuild/test.ml b/test/blackbox-tests/test-cases/preprocess-with-action/jbuild/test.ml new file mode 100644 index 00000000..cec6d9fa --- /dev/null +++ b/test/blackbox-tests/test-cases/preprocess-with-action/jbuild/test.ml @@ -0,0 +1 @@ +print_endline _STRING_ diff --git a/test/blackbox-tests/test-cases/preprocess-with-action/pp/dune b/test/blackbox-tests/test-cases/preprocess-with-action/pp/dune new file mode 100644 index 00000000..8fda4b24 --- /dev/null +++ b/test/blackbox-tests/test-cases/preprocess-with-action/pp/dune @@ -0,0 +1,4 @@ +(executable + (name pp)) + +(ocamllex pp) diff --git a/test/blackbox-tests/test-cases/preprocess-with-action/pp/pp.mll b/test/blackbox-tests/test-cases/preprocess-with-action/pp/pp.mll new file mode 100644 index 00000000..5cd344e7 --- /dev/null +++ b/test/blackbox-tests/test-cases/preprocess-with-action/pp/pp.mll @@ -0,0 +1,10 @@ +rule main = parse + | eof { () } + | "_STRING_" { Printf.printf "%S" "Hello, world!"; main lexbuf } + | _ as c { print_char c; main lexbuf } + +{ + let () = + set_binary_mode_out stdout true; + main (Lexing.from_channel (open_in_bin Sys.argv.(1))) +} diff --git a/test/blackbox-tests/test-cases/preprocess-with-action/run.t b/test/blackbox-tests/test-cases/preprocess-with-action/run.t new file mode 100644 index 00000000..b5f24afd --- /dev/null +++ b/test/blackbox-tests/test-cases/preprocess-with-action/run.t @@ -0,0 +1,4 @@ + $ dune runtest + File "dune/dune", line 3, characters 38-48: + Error: unknown variable "first-dep" + [1] From 38c0d56ba8df239a59403e00cb675784fa16ed95 Mon Sep 17 00:00:00 2001 From: Jeremie Dimino Date: Mon, 9 Jul 2018 17:24:04 +0100 Subject: [PATCH 20/34] Name the intput file for action preprocessors Signed-off-by: Jeremie Dimino --- doc/dune-files.rst | 12 ++++++------ src/preprocessing.ml | 5 +++-- .../test-cases/preprocess-with-action/dune/dune | 2 +- .../test-cases/preprocess-with-action/run.t | 3 --- 4 files changed, 10 insertions(+), 12 deletions(-) diff --git a/doc/dune-files.rst b/doc/dune-files.rst index 68dc9f79..9fd9a61e 100644 --- a/doc/dune-files.rst +++ b/doc/dune-files.rst @@ -1038,11 +1038,11 @@ the ``-pp`` or ``-ppx`` of the various OCaml tools. Preprocessing with actions ~~~~~~~~~~~~~~~~~~~~~~~~~~ -```` uses the same DSL as described in the `User actions`_ section, and -for the same reason given in that section, it will be executed from the root of -the current build context. It is expected to be an action that reads the file -given as only dependency and outputs the preprocessed file on its standard -output. +```` uses the same DSL as described in the `User actions`_ +section, and for the same reason given in that section, it will be +executed from the root of the current build context. It is expected to +be an action that reads the file given as only dependency named +``input-file`` and outputs the preprocessed file on its standard output. More precisely, ``(preprocess (action ))`` acts as if you had setup a rule for every file of the form: @@ -1055,7 +1055,7 @@ you had setup a rule for every file of the form: (action (with-stdout-to %{@} (chdir %{root} )))) The equivalent of a ``-pp `` option passed to the OCaml compiler is -``(system " %{<}")``. +``(system " %{input-file}")``. Preprocessing with ppx rewriters ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/src/preprocessing.ml b/src/preprocessing.ml index d7584716..1a280a37 100644 --- a/src/preprocessing.ml +++ b/src/preprocessing.ml @@ -456,7 +456,8 @@ let lint_module sctx ~dir ~dep_kind ~lint ~lib_name ~scope ~dir_kind = let src_path = Path.relative dir src.name in add_alias src.name (Build.path src_path - >>^ (fun _ -> Jbuild.Bindings.singleton src_path) + >>^ (fun _ -> + [Jbuild.Bindings.Named ("input-file", [src_path])]) >>> SC.Action.run sctx action ~loc @@ -532,7 +533,7 @@ let make sctx ~dir ~dep_kind ~lint ~preprocess (preprocessor_deps >>> Build.path src - >>^ (fun _ -> Jbuild.Bindings.singleton src) + >>^ (fun _ -> [Jbuild.Bindings.Named ("input-file", [src])]) >>> SC.Action.run sctx (Redirect diff --git a/test/blackbox-tests/test-cases/preprocess-with-action/dune/dune b/test/blackbox-tests/test-cases/preprocess-with-action/dune/dune index e0af31fc..4616e711 100644 --- a/test/blackbox-tests/test-cases/preprocess-with-action/dune/dune +++ b/test/blackbox-tests/test-cases/preprocess-with-action/dune/dune @@ -1,3 +1,3 @@ (test (name test) - (preprocess (action (run pp/pp.exe %{first-dep})))) + (preprocess (action (run pp/pp.exe %{input-file})))) diff --git a/test/blackbox-tests/test-cases/preprocess-with-action/run.t b/test/blackbox-tests/test-cases/preprocess-with-action/run.t index b5f24afd..10bcbf13 100644 --- a/test/blackbox-tests/test-cases/preprocess-with-action/run.t +++ b/test/blackbox-tests/test-cases/preprocess-with-action/run.t @@ -1,4 +1 @@ $ dune runtest - File "dune/dune", line 3, characters 38-48: - Error: unknown variable "first-dep" - [1] From c10a2c254ef3c60f3951be5a37de79c4829ff67b Mon Sep 17 00:00:00 2001 From: Jeremie Dimino Date: Mon, 9 Jul 2018 17:32:55 +0100 Subject: [PATCH 21/34] Remove a couple of extra begin..end Signed-off-by: Jeremie Dimino --- src/super_context.ml | 8 +++----- 1 file changed, 3 insertions(+), 5 deletions(-) diff --git a/src/super_context.ml b/src/super_context.ml index 37da70f2..03df821d 100644 --- a/src/super_context.ml +++ b/src/super_context.ml @@ -778,14 +778,14 @@ module Action = struct match String.Map.find dynamic_expansions key with | Some _ as opt -> opt | None -> - begin match + match Pform.Map.expand Pform.Map.static_vars ~syntax_version ~var with | None -> Jbuild.Bindings.find deps_written_by_user key |> Option.map ~f:Value.L.paths | Some x -> - begin match x with + match x with Pform.Var.Deps -> deps_written_by_user |> Jbuild.Bindings.to_list @@ -803,9 +803,7 @@ module Action = struct end | _ -> Exn.code_error "Unexpected variable in step2" - ["var", String_with_vars.Var.sexp_of_t var] - end - end) + ["var", String_with_vars.Var.sexp_of_t var]) let run sctx ~loc ?(extra_vars=String.Map.empty) ~bindings t ~dir ~dep_kind ~targets:targets_written_by_user ~scope From 61a80a6bb3a66a706d630f9b6bc3ebb85c538e6c Mon Sep 17 00:00:00 2001 From: Jeremie Dimino Date: Mon, 9 Jul 2018 17:36:04 +0100 Subject: [PATCH 22/34] Simplify a bit expand_step2 Signed-off-by: Jeremie Dimino --- src/jbuild.ml | 8 -------- src/jbuild.mli | 2 -- src/super_context.ml | 13 ++++++++----- 3 files changed, 8 insertions(+), 15 deletions(-) diff --git a/src/jbuild.ml b/src/jbuild.ml index 8a36823a..eb1f05fa 100644 --- a/src/jbuild.ml +++ b/src/jbuild.ml @@ -251,14 +251,6 @@ module Bindings = struct | Unnamed _ -> None | Named (k', x) -> Option.some_if (k = k') x) - let first t = - let rec loop acc = function - | [] -> acc - | Unnamed x :: xs -> loop (Result.Ok x) xs - | Named (_, _) :: _ -> Result.Error `Named_exists - in - loop (Result.Error `Empty) t - let empty = [] let singleton x = [Unnamed x] diff --git a/src/jbuild.mli b/src/jbuild.mli index 2b796925..9e290d77 100644 --- a/src/jbuild.mli +++ b/src/jbuild.mli @@ -98,8 +98,6 @@ module Bindings : sig val singleton : 'a -> 'a t - val first : 'a t -> ('a, [`Empty | `Named_exists]) Result.t - val sexp_of_t : ('a -> Usexp.t) -> 'a t -> Usexp.t end diff --git a/src/super_context.ml b/src/super_context.ml index 03df821d..b0ac1ea7 100644 --- a/src/super_context.ml +++ b/src/super_context.ml @@ -792,14 +792,17 @@ module Action = struct |> Value.L.paths |> Option.some | First_dep -> - begin match Jbuild.Bindings.first deps_written_by_user with - | Error `Named_exists -> - Loc.fail loc "%%{first-dep} is not allowed with named dependencies" - | Error `Empty -> + begin match deps_written_by_user with + | Named _ :: _ -> + (* This case is not possible: ${<} only exist in jbuild + files and named dependencies are not available in + jbuild files *) + assert false + | Unnamed v :: _ -> Some [Path v] + | [] -> Loc.warn loc "Variable '%s' used with no explicit \ dependencies@." key; Some [Value.String ""] - | Ok v -> Some [Path v] end | _ -> Exn.code_error "Unexpected variable in step2" From abab989e2026566542dab4f587e9a3180fece6cd Mon Sep 17 00:00:00 2001 From: Jeremie Dimino Date: Mon, 9 Jul 2018 17:38:43 +0100 Subject: [PATCH 23/34] Remove extra module path Signed-off-by: Jeremie Dimino --- src/super_context.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/super_context.ml b/src/super_context.ml index b0ac1ea7..133e44e6 100644 --- a/src/super_context.ml +++ b/src/super_context.ml @@ -786,7 +786,7 @@ module Action = struct |> Option.map ~f:Value.L.paths | Some x -> match x with - Pform.Var.Deps -> + | Deps -> deps_written_by_user |> Jbuild.Bindings.to_list |> Value.L.paths From 4f7e7188d7242272ba1002dda0c6dedfa114a3ff Mon Sep 17 00:00:00 2001 From: Rudi Grinberg Date: Mon, 9 Jul 2018 23:39:57 +0700 Subject: [PATCH 24/34] Implemenet variable shadowing Signed-off-by: Rudi Grinberg --- src/inline_tests.ml | 21 +++++----- src/pform.ml | 6 +++ src/pform.mli | 4 ++ src/preprocessing.ml | 14 ++++--- src/super_context.ml | 39 ++++++++++--------- src/super_context.mli | 7 ++-- .../test-cases/shadow-bindings/run.t | 2 +- 7 files changed, 52 insertions(+), 41 deletions(-) diff --git a/src/inline_tests.ml b/src/inline_tests.ml index 4e7522a1..b918eb19 100644 --- a/src/inline_tests.ml +++ b/src/inline_tests.ml @@ -179,8 +179,9 @@ include Sub_system.Register_end_point( ~obj_name:name) in - let extra_vars = - String.Map.singleton "library-name" ([Value.String lib.name]) + let bindings = + Pform.Map.singleton "library-name" + (Pform.Var.Values [Value.String lib.name]) in let runner_libs = @@ -202,17 +203,15 @@ include Sub_system.Register_end_point( let target = Path.relative inline_test_dir main_module_filename in let source_modules = Module.Name.Map.values source_modules in let files ml_kind = - Value.L.paths ( + Pform.Var.Values (Value.L.paths ( List.filter_map source_modules ~f:(fun m -> - Module.file m ~dir ml_kind)) + Module.file m ~dir ml_kind))) in - let extra_vars = - List.fold_left + let bindings = + Pform.Map.of_list_exn [ "impl-files", files Impl ; "intf-files", files Intf ] - ~init:extra_vars - ~f:(fun acc (k, v) -> String.Map.add acc k v) in Build.return Bindings.empty >>> @@ -220,8 +219,8 @@ include Sub_system.Register_end_point( (List.filter_map backends ~f:(fun (backend : Backend.t) -> Option.map backend.info.generate_runner ~f:(fun (loc, action) -> SC.Action.run sctx action ~loc - ~bindings:Pform.Map.empty - ~extra_vars ~dir ~dep_kind:Required ~targets:Alias ~scope))) + ~bindings + ~dir ~dep_kind:Required ~targets:Alias ~scope))) >>^ (fun actions -> Action.with_stdout_to target (Action.progn actions)) @@ -252,7 +251,7 @@ include Sub_system.Register_end_point( Super_context.expand_and_eval_set sctx flags ~scope ~dir - ~extra_vars + ~bindings ~standard:(Build.return []))) >>^ List.concat in diff --git a/src/pform.ml b/src/pform.ml index f2f96eec..cf87d265 100644 --- a/src/pform.ml +++ b/src/pform.ml @@ -183,6 +183,12 @@ module Map = struct let empty = String.Map.empty + let singleton k v = String.Map.singleton k (No_info v) + + let of_list_exn vars = + List.map ~f:(fun (k, x) -> (k, No_info x)) vars + |> String.Map.of_list_exn + let of_bindings = Jbuild.Bindings.fold ~f:(fun x acc -> match x with diff --git a/src/pform.mli b/src/pform.mli index 9e1149a8..f33818ef 100644 --- a/src/pform.mli +++ b/src/pform.mli @@ -46,6 +46,10 @@ module Map : sig val of_bindings : 'a Jbuild.Bindings.t -> Var.t t + val singleton : string -> 'a -> 'a t + + val of_list_exn : (string * 'a) list -> 'a t + val expand : 'a t -> syntax_version:Syntax.Version.t diff --git a/src/preprocessing.ml b/src/preprocessing.ml index 1a280a37..e635d893 100644 --- a/src/preprocessing.ml +++ b/src/preprocessing.ml @@ -478,14 +478,15 @@ let lint_module sctx ~dir ~dep_kind ~lint ~lib_name ~scope ~dir_kind = get_ppx_driver sctx ~loc ~scope ~dir_kind pps >>| fun (exe, driver) -> (exe, - let extra_vars = - String_map.singleton "corrected-suffix" [Value.String corrected_suffix] + let bindings = + Pform.Map.singleton "corrected-suffix" + (Pform.Var.Values [Value.String corrected_suffix]) in Build.memoize "ppx flags" (SC.expand_and_eval_set sctx driver.info.lint_flags ~scope ~dir - ~extra_vars + ~bindings ~standard:(Build.return []))) in (fun ~source ~ast -> @@ -561,14 +562,15 @@ let make sctx ~dir ~dep_kind ~lint ~preprocess let open Result.O in get_ppx_driver sctx ~loc ~scope ~dir_kind pps >>| fun (exe, driver) -> (exe, - let extra_vars = - String_map.singleton "corrected-suffix" [Value.String corrected_suffix] + let bindings = + Pform.Map.singleton "corrected-suffix" + (Pform.Var.Values [Value.String corrected_suffix]) in Build.memoize "ppx flags" (SC.expand_and_eval_set sctx driver.info.flags ~scope ~dir - ~extra_vars + ~bindings ~standard:(Build.return []))) in (fun m ~lint -> diff --git a/src/super_context.ml b/src/super_context.ml index 133e44e6..fa72e423 100644 --- a/src/super_context.ml +++ b/src/super_context.ml @@ -112,11 +112,13 @@ let expand t ~syntax_version ~var = | Left (Some x) -> Some (Left x) let (expand_vars_string, expand_vars_path) = - let expand t ~scope ~dir ?(extra_vars=String.Map.empty) s = + let expand t ~scope ~dir ?(bindings=Pform.Map.empty) s = String_with_vars.expand ~mode:Single ~dir s ~f:(fun var syntax_version -> match expand t ~syntax_version ~var with | None -> - String.Map.find extra_vars (String_with_vars.Var.full_name var) + let open Option.O in + Pform.Map.expand bindings ~syntax_version ~var >>= + Pform.Var.to_value_no_deps_or_targets ~scope | Some (Left v) -> begin match Pform.Var.to_value_no_deps_or_targets ~scope v with | Some _ as v -> v @@ -131,19 +133,19 @@ let (expand_vars_string, expand_vars_path) = Loc.fail (String_with_vars.Var.loc var) "This percent form isn't allowed in this position") in - let expand_vars t ~scope ~dir ?extra_vars s = - expand t ~scope ~dir ?extra_vars s + let expand_vars t ~scope ~dir ?bindings s = + expand t ~scope ~dir ?bindings s |> Value.to_string ~dir in - let expand_vars_path t ~scope ~dir ?extra_vars s = - expand t ~scope ~dir ?extra_vars s + let expand_vars_path t ~scope ~dir ?bindings s = + expand t ~scope ~dir ?bindings s |> Value.to_path ~error_loc:(String_with_vars.loc s) ~dir in (expand_vars, expand_vars_path) -let expand_and_eval_set t ~scope ~dir ?extra_vars set ~standard = +let expand_and_eval_set t ~scope ~dir ?bindings set ~standard = let open Build.O in - let f = expand_vars_string t ~scope ~dir ?extra_vars in + let f = expand_vars_string t ~scope ~dir ?bindings in let parse ~loc:_ s = s in let (syntax, files) = Ordered_set_lang.Unexpanded.files set ~f in match String.Set.to_list files with @@ -208,7 +210,7 @@ module Env = struct ~ocamlopt_flags:cfg.ocamlopt_flags ~default ~eval:(expand_and_eval_set t ~scope:node.scope ~dir:node.dir - ?extra_vars:None) + ?bindings:None) in node.ocaml_flags <- Some flags; flags @@ -223,7 +225,7 @@ let ocaml_flags t ~dir ~scope (x : Buildable.t) = ~ocamlc_flags:x.ocamlc_flags ~ocamlopt_flags:x.ocamlopt_flags ~default:(Env.ocaml_flags t ~dir) - ~eval:(expand_and_eval_set t ~scope ~dir ?extra_vars:None) + ~eval:(expand_and_eval_set t ~scope ~dir ?bindings:None) let dump_env t ~dir = Ocaml_flags.dump (Env.ocaml_flags t ~dir) @@ -630,7 +632,7 @@ module Action = struct | Some x -> x let expand_step1 sctx ~dir ~dep_kind ~scope ~targets_written_by_user - ~map_exe ~extra_vars t = + ~map_exe ~bindings t = let acc = { failures = [] ; lib_deps = String.Map.empty @@ -735,14 +737,13 @@ module Action = struct in let expand var syntax_version = let loc = String_with_vars.Var.loc var in - let key = String_with_vars.Var.full_name var in let res = match String_with_vars.Var.destruct var with | Macro (_, s) -> expand_form s var syntax_version | Var var_name -> - begin match expand_vars sctx ~syntax_version ~var with - | None -> String.Map.find extra_vars key - | Some Targets -> + begin match Pform.Map.expand bindings ~syntax_version ~var with + | None -> None + | Some Pform.Var.Targets -> let var () = match var_name with | "@" -> sprintf "${%s}" var_name @@ -808,10 +809,9 @@ module Action = struct Exn.code_error "Unexpected variable in step2" ["var", String_with_vars.Var.sexp_of_t var]) - let run sctx ~loc ?(extra_vars=String.Map.empty) ~bindings - t ~dir ~dep_kind ~targets:targets_written_by_user ~scope + let run sctx ~loc ~bindings t ~dir ~dep_kind + ~targets:targets_written_by_user ~scope : (Path.t Bindings.t, Action.t) Build.t = - ignore bindings; let map_exe = map_exe sctx in if targets_written_by_user = Alias then begin match Action.Infer.unexpanded_targets t with @@ -823,8 +823,9 @@ module Action = struct This will become an error in the future."; end; let t, forms = + let bindings = Pform.Map.superpose sctx.vars bindings in expand_step1 sctx t ~dir ~dep_kind ~scope - ~targets_written_by_user ~map_exe ~extra_vars + ~targets_written_by_user ~map_exe ~bindings in let { Action.Infer.Outcome. deps; targets } = match targets_written_by_user with diff --git a/src/super_context.mli b/src/super_context.mli index f203db79..913ab515 100644 --- a/src/super_context.mli +++ b/src/super_context.mli @@ -82,7 +82,7 @@ val expand_vars_string : t -> scope:Scope.t -> dir:Path.t - -> ?extra_vars:Value.t list String.Map.t + -> ?bindings:Pform.Var.t Pform.Map.t -> String_with_vars.t -> string @@ -90,7 +90,7 @@ val expand_vars_path : t -> scope:Scope.t -> dir:Path.t - -> ?extra_vars:Value.t list String.Map.t + -> ?bindings:Pform.Var.t Pform.Map.t -> String_with_vars.t -> Path.t @@ -98,7 +98,7 @@ val expand_and_eval_set : t -> scope:Scope.t -> dir:Path.t - -> ?extra_vars:Value.t list String.Map.t + -> ?bindings:Pform.Var.t Pform.Map.t -> Ordered_set_lang.Unexpanded.t -> standard:(unit, string list) Build.t -> (unit, string list) Build.t @@ -239,7 +239,6 @@ module Action : sig val run : t -> loc:Loc.t - -> ?extra_vars:Value.t list String.Map.t -> bindings:Pform.Var.t Pform.Map.t -> Action.Unexpanded.t -> dir:Path.t diff --git a/test/blackbox-tests/test-cases/shadow-bindings/run.t b/test/blackbox-tests/test-cases/shadow-bindings/run.t index 565385e9..015e5376 100644 --- a/test/blackbox-tests/test-cases/shadow-bindings/run.t +++ b/test/blackbox-tests/test-cases/shadow-bindings/run.t @@ -1,4 +1,4 @@ Bindings introduced by user dependencies should shadow existing bindings $ dune runtest - . + foo From 46e8614e909c38113711c97e18d4b117ab925cd9 Mon Sep 17 00:00:00 2001 From: Jeremie Dimino Date: Mon, 9 Jul 2018 17:50:18 +0100 Subject: [PATCH 25/34] Hide Pform.t Signed-off-by: Jeremie Dimino --- src/pform.mli | 9 +-------- 1 file changed, 1 insertion(+), 8 deletions(-) diff --git a/src/pform.mli b/src/pform.mli index f33818ef..ccbe4e09 100644 --- a/src/pform.mli +++ b/src/pform.mli @@ -26,14 +26,7 @@ module Macro : sig | Ocaml_config end -type 'a t = - | No_info of 'a - | Since of 'a * Syntax.Version.t - | Deleted_in of 'a * Syntax.Version.t * string option - | Renamed_in of Syntax.Version.t * string - module Map : sig - type 'a var type 'a t val create_vars : context:Context.t -> cxx_flags:string list -> Var.t t @@ -57,4 +50,4 @@ module Map : sig -> 'a option val empty : 'a t -end with type 'a var := 'a t +end From 0b2bda03ed0be8c61e9c9f74f097f6782555e35f Mon Sep 17 00:00:00 2001 From: Jeremie Dimino Date: Mon, 9 Jul 2018 18:41:10 +0100 Subject: [PATCH 26/34] Refactor percent forms management Use a single map for both variables and percent forms Signed-off-by: Jeremie Dimino --- src/inline_tests.ml | 4 +- src/pform.ml | 144 ++++---- src/pform.mli | 75 ++-- src/preprocessing.ml | 17 +- src/string_with_vars.ml | 16 +- src/string_with_vars.mli | 6 +- src/super_context.ml | 323 +++++++++--------- src/super_context.mli | 8 +- .../test-cases/macro-expand-error/run.t | 2 +- 9 files changed, 280 insertions(+), 315 deletions(-) diff --git a/src/inline_tests.ml b/src/inline_tests.ml index b918eb19..1c7ebd84 100644 --- a/src/inline_tests.ml +++ b/src/inline_tests.ml @@ -181,7 +181,7 @@ include Sub_system.Register_end_point( let bindings = Pform.Map.singleton "library-name" - (Pform.Var.Values [Value.String lib.name]) + (Values [String lib.name]) in let runner_libs = @@ -203,7 +203,7 @@ include Sub_system.Register_end_point( let target = Path.relative inline_test_dir main_module_filename in let source_modules = Module.Name.Map.values source_modules in let files ml_kind = - Pform.Var.Values (Value.L.paths ( + Pform.Values (Value.L.paths ( List.filter_map source_modules ~f:(fun m -> Module.file m ~dir ml_kind))) in diff --git a/src/pform.ml b/src/pform.ml index cf87d265..67a3270f 100644 --- a/src/pform.ml +++ b/src/pform.ml @@ -1,60 +1,46 @@ open Import -module Var = struct - type t = - | Values of Value.t list - | Project_root - | First_dep - | Deps - | Targets - | Named_local +type t = + | Values of Value.t list + | Project_root + | First_dep + | Deps + | Targets + | Named_local + | Exe + | Dep + | Bin + | Lib + | Libexec + | Lib_available + | Version + | Read + | Read_strings + | Read_lines + | Path_no_dep + | Ocaml_config - let to_value_no_deps_or_targets t ~scope = - match t with - | Values v -> Some v - | Project_root -> Some [Value.Dir (Scope.root scope)] - | First_dep - | Deps - | Named_local - | Targets -> None -end - -module Macro = struct - type t = - | Exe - | Dep - | Bin - | Lib - | Libexec - | Lib_available - | Version - | Read - | Read_strings - | Read_lines - | Path_no_dep - | Ocaml_config -end - -type 'a t = - | No_info of 'a - | Since of 'a * Syntax.Version.t - | Deleted_in of 'a * Syntax.Version.t * string option +type with_info = + | No_info of t + | Since of t * Syntax.Version.t + | Deleted_in of t * Syntax.Version.t * string option | Renamed_in of Syntax.Version.t * string module Map = struct - type nonrec 'a t = 'a t String.Map.t + type t = with_info String.Map.t - let values v = No_info (Var.Values v) + let values v = No_info (Values v) let renamed_in ~new_name ~version = Renamed_in (version, new_name) let deleted_in ~version ?repl kind = Deleted_in (kind, version, repl) let since ~version v = Since (v, version) - let static_vars = - [ "targets", since ~version:(1, 0) Var.Targets - ; "deps", since ~version:(1, 0) Var.Deps - ; "project_root", since ~version:(1, 0) Var.Project_root + let static = + let macro x = No_info x in + [ "targets", since ~version:(1, 0) Targets + ; "deps", since ~version:(1, 0) Deps + ; "project_root", since ~version:(1, 0) Project_root - ; "<", deleted_in Var.Deps ~version:(1, 0) + ; "<", deleted_in Deps ~version:(1, 0) ~repl:"Use a named dependency instead:\ \n\ \n\ (deps (:x ) ...)\ @@ -62,12 +48,8 @@ module Map = struct ; "@", renamed_in ~version:(1, 0) ~new_name:"targets" ; "^", renamed_in ~version:(1, 0) ~new_name:"deps" ; "SCOPE_ROOT", renamed_in ~version:(1, 0) ~new_name:"project_root" - ] - let macros = - let macro kind = No_info kind in - let open Macro in - [ "exe", macro Exe + ; "exe", macro Exe ; "bin", macro Bin ; "lib", macro Lib ; "libexec", macro Libexec @@ -87,7 +69,7 @@ module Map = struct ] |> String.Map.of_list_exn - let create_vars ~(context : Context.t) ~cxx_flags = + let create ~(context : Context.t) ~cxx_flags = let ocamlopt = match context.ocamlopt with | None -> Path.relative context.ocaml_bin "ocamlopt" @@ -112,11 +94,13 @@ module Map = struct ; "arch_sixtyfour" , string (string_of_bool context.arch_sixtyfour) ; "make" , make ; "root" , values [Value.Dir context.build_dir] - ] in + ] + in let uppercased = List.map lowercased ~f:(fun (k, _) -> - (String.uppercase k, renamed_in ~new_name:k ~version:(1, 0))) in - let vars = + (String.uppercase k, renamed_in ~new_name:k ~version:(1, 0))) + in + let other = [ "-verbose" , values [] ; "pa_cpp" , strings (context.c_compiler :: cflags @ ["-undef"; "-traditional"; @@ -133,66 +117,60 @@ module Map = struct ; "profile" , string context.profile ] in - [ static_vars - ; lowercased - ; uppercased - ; vars - ] - |> List.concat - |> String.Map.of_list_exn - - let static_vars = String.Map.of_list_exn static_vars + String.Map.superpose + static + (String.Map.of_list_exn + (List.concat + [ lowercased + ; uppercased + ; other + ])) let superpose = String.Map.superpose - let rec expand t ~syntax_version ~var = - let name = String_with_vars.Var.name var in + let rec expand t ~syntax_version ~pform = + let name = String_with_vars.Var.name pform in Option.bind (String.Map.find t name) ~f:(fun v -> - let what var = - String_with_vars.Var.to_string ( - if String_with_vars.Var.is_macro var then - String_with_vars.Var.with_payload var ~payload:(Some "..") - else - var) - in + let describe = String_with_vars.Var.describe in match v with | No_info v -> Some v | Since (v, min_version) -> if syntax_version >= min_version then Some v else - Syntax.Error.since (String_with_vars.Var.loc var) + Syntax.Error.since (String_with_vars.Var.loc pform) Stanza.syntax min_version - ~what:(what var) + ~what:(describe pform) | Renamed_in (in_version, new_name) -> begin if syntax_version >= in_version then - Syntax.Error.renamed_in (String_with_vars.Var.loc var) + Syntax.Error.renamed_in (String_with_vars.Var.loc pform) Stanza.syntax syntax_version - ~what:(what var) - ~to_:(what (String_with_vars.Var.with_name var ~name:new_name)) + ~what:(describe pform) + ~to_:(describe + (String_with_vars.Var.with_name pform ~name:new_name)) else expand t ~syntax_version:in_version - ~var:(String_with_vars.Var.with_name var ~name:new_name) + ~pform:(String_with_vars.Var.with_name pform ~name:new_name) end | Deleted_in (v, in_version, repl) -> if syntax_version < in_version then Some v else - Syntax.Error.deleted_in (String_with_vars.Var.loc var) - Stanza.syntax syntax_version ~what:(what var) ?repl) + Syntax.Error.deleted_in (String_with_vars.Var.loc pform) + Stanza.syntax syntax_version ~what:(describe pform) ?repl) let empty = String.Map.empty let singleton k v = String.Map.singleton k (No_info v) - let of_list_exn vars = - List.map ~f:(fun (k, x) -> (k, No_info x)) vars + let of_list_exn pforms = + List.map ~f:(fun (k, x) -> (k, No_info x)) pforms |> String.Map.of_list_exn let of_bindings = Jbuild.Bindings.fold ~f:(fun x acc -> match x with | Unnamed _ -> acc - | Named (s, _) -> String.Map.add acc s (No_info Var.Named_local) + | Named (s, _) -> String.Map.add acc s (No_info Named_local) ) ~init:empty end diff --git a/src/pform.mli b/src/pform.mli index ccbe4e09..471dab57 100644 --- a/src/pform.mli +++ b/src/pform.mli @@ -1,53 +1,46 @@ -module Var : sig - type t = - | Values of Value.t list - | Project_root - | First_dep - | Deps - | Targets - | Named_local +type t = + (* Variables *) + | Values of Value.t list + | Project_root + | First_dep + | Deps + | Targets + | Named_local - val to_value_no_deps_or_targets : t -> scope:Scope.t -> Value.t list option -end - -module Macro : sig - type t = - | Exe - | Dep - | Bin - | Lib - | Libexec - | Lib_available - | Version - | Read - | Read_strings - | Read_lines - | Path_no_dep - | Ocaml_config -end + (* Macros *) + | Exe + | Dep + | Bin + | Lib + | Libexec + | Lib_available + | Version + | Read + | Read_strings + | Read_lines + | Path_no_dep + | Ocaml_config module Map : sig - type 'a t + type pform + type t - val create_vars : context:Context.t -> cxx_flags:string list -> Var.t t + val create : context:Context.t -> cxx_flags:string list -> t - val macros : Macro.t t + val superpose : t -> t -> t - val static_vars : Var.t t + (** Map with all named values as [Named_local] *) + val of_bindings : _ Jbuild.Bindings.t -> t - val superpose : 'a t -> 'a t -> 'a t + val singleton : string -> pform -> t - val of_bindings : 'a Jbuild.Bindings.t -> Var.t t - - val singleton : string -> 'a -> 'a t - - val of_list_exn : (string * 'a) list -> 'a t + val of_list_exn : (string * pform) list -> t val expand - : 'a t + : t -> syntax_version:Syntax.Version.t - -> var:String_with_vars.Var.t - -> 'a option + -> pform:String_with_vars.Var.t + -> pform option - val empty : 'a t -end + val empty : t +end with type pform := t diff --git a/src/preprocessing.ml b/src/preprocessing.ml index e635d893..904694ac 100644 --- a/src/preprocessing.ml +++ b/src/preprocessing.ml @@ -454,16 +454,18 @@ let lint_module sctx ~dir ~dep_kind ~lint ~lib_name ~scope ~dir_kind = let action = Action.Unexpanded.Chdir (root_var, action) in Module.iter source ~f:(fun _ (src : Module.File.t) -> let src_path = Path.relative dir src.name in + let bindings = + [Jbuild.Bindings.Named ("input-file", [src_path])] + in add_alias src.name (Build.path src_path - >>^ (fun _ -> - [Jbuild.Bindings.Named ("input-file", [src_path])]) + >>^ (fun _ -> bindings) >>> SC.Action.run sctx action ~loc ~dir ~dep_kind - ~bindings:Pform.Map.empty + ~bindings:(Pform.Map.of_bindings bindings) ~targets:(Static []) ~scope))) | Pps { loc; pps; flags } -> @@ -480,7 +482,7 @@ let lint_module sctx ~dir ~dep_kind ~lint ~lib_name ~scope ~dir_kind = (exe, let bindings = Pform.Map.singleton "corrected-suffix" - (Pform.Var.Values [Value.String corrected_suffix]) + (Values [String corrected_suffix]) in Build.memoize "ppx flags" (SC.expand_and_eval_set sctx driver.info.lint_flags @@ -530,11 +532,12 @@ let make sctx ~dir ~dep_kind ~lint ~preprocess (fun m ~lint -> let ast = pped_module m ~dir ~f:(fun _kind src dst -> + let bindings = [Jbuild.Bindings.Named ("input-file", [src])] in SC.add_rule sctx (preprocessor_deps >>> Build.path src - >>^ (fun _ -> [Jbuild.Bindings.Named ("input-file", [src])]) + >>^ (fun _ -> bindings) >>> SC.Action.run sctx (Redirect @@ -545,7 +548,7 @@ let make sctx ~dir ~dep_kind ~lint ~preprocess ~loc ~dir ~dep_kind - ~bindings:Pform.Map.empty + ~bindings:(Pform.Map.of_bindings bindings) ~targets:(Static [dst]) ~scope)) |> setup_reason_rules sctx ~dir in @@ -564,7 +567,7 @@ let make sctx ~dir ~dep_kind ~lint ~preprocess (exe, let bindings = Pform.Map.singleton "corrected-suffix" - (Pform.Var.Values [Value.String corrected_suffix]) + (Values [String corrected_suffix]) in Build.memoize "ppx flags" (SC.expand_and_eval_set sctx driver.info.flags diff --git a/src/string_with_vars.ml b/src/string_with_vars.ml index 04aa239f..4fc95d08 100644 --- a/src/string_with_vars.ml +++ b/src/string_with_vars.ml @@ -211,6 +211,8 @@ module Var = struct | Var s -> s | Macro (k, v) -> k ^ ":" ^ v + let payload t = t.payload + let to_string = string_of_var let pp fmt t = Format.pp_print_string fmt (to_string t) @@ -224,6 +226,12 @@ module Var = struct { t with name } let is_macro t = Option.is_some t.payload + + let describe t = + to_string + (match t.payload with + | None -> t + | Some _ -> { t with payload = Some ".." }) end let partial_expand @@ -277,10 +285,10 @@ let expand t ~mode ~dir ~f = | None -> begin match var.syntax with | Percent -> - begin match Var.destruct var with - | Var v -> Loc.fail var.loc "unknown variable %S" v - | Macro _ -> Loc.fail var.loc "unknown form %s" (string_of_var var) - end + if Var.is_macro var then + Loc.fail var.loc "Unknown macro %s" (Var.describe var) + else + Loc.fail var.loc "Unknown variable %S" (Var.name var) | Dollar_brace | Dollar_paren -> Some [Value.String (string_of_var var)] end diff --git a/src/string_with_vars.mli b/src/string_with_vars.mli index ddb09575..aa2f2046 100644 --- a/src/string_with_vars.mli +++ b/src/string_with_vars.mli @@ -56,6 +56,7 @@ module Var : sig val name : t -> string val loc : t -> Loc.t val full_name : t -> string + val payload : t -> string option type kind = | Var of string @@ -63,13 +64,14 @@ module Var : sig val destruct : t -> kind - val to_string : t -> string - val with_name : t -> name:string -> t val with_payload : t -> payload:string option -> t val is_macro : t -> bool + + (** Describe what this variable is *) + val describe : t -> string end val expand diff --git a/src/super_context.ml b/src/super_context.ml index fa72e423..2da87520 100644 --- a/src/super_context.ml +++ b/src/super_context.ml @@ -45,8 +45,7 @@ type t = ; artifacts : Artifacts.t ; stanzas_to_consider_for_install : Installable.t list ; cxx_flags : string list - ; vars : Pform.Var.t Pform.Map.t - ; macros : Pform.Macro.t Pform.Map.t + ; pforms : Pform.Map.t ; ocaml_config : Value.t list String.Map.t ; chdir : (Action.t, Action.t) Build.t ; host : t option @@ -86,52 +85,33 @@ let installed_libs t = t.installed_libs let find_scope_by_dir t dir = Scope.DB.find_by_dir t.scopes dir let find_scope_by_name t name = Scope.DB.find_by_name t.scopes name -let expand_vars t ~syntax_version ~var = - if String_with_vars.Var.is_macro var then - Loc.fail (String_with_vars.Var.loc var) - "macros of the form %%{name:..} cannot be expanded here" - else - Pform.Map.expand t.vars ~syntax_version ~var - -let expand_macro t ~syntax_version ~var = - if String_with_vars.Var.is_macro var then - Pform.Map.expand t.macros ~syntax_version ~var - else - Exn.code_error "expand_macro can't expand variables" - [ "var", String_with_vars.Var.sexp_of_t var ] - -let expand t ~syntax_version ~var = - match - match String_with_vars.Var.destruct var with - | Var _ -> Left (expand_vars t ~syntax_version ~var) - | Macro (_, _) -> Right (expand_macro t ~syntax_version ~var) - with - | Right None - | Left None -> None - | Right (Some x) -> Some (Right x) - | Left (Some x) -> Some (Left x) +let expand_ocaml_config t pform = + let name = Option.value_exn (String_with_vars.Var.payload pform) in + match String.Map.find t.ocaml_config name with + | Some x -> x + | None -> + Loc.fail (String_with_vars.Var.loc pform) + "Unknown ocaml configuration variable %S" + name let (expand_vars_string, expand_vars_path) = let expand t ~scope ~dir ?(bindings=Pform.Map.empty) s = - String_with_vars.expand ~mode:Single ~dir s ~f:(fun var syntax_version -> - match expand t ~syntax_version ~var with - | None -> - let open Option.O in - Pform.Map.expand bindings ~syntax_version ~var >>= - Pform.Var.to_value_no_deps_or_targets ~scope - | Some (Left v) -> - begin match Pform.Var.to_value_no_deps_or_targets ~scope v with - | Some _ as v -> v - | None -> - Loc.fail (String_with_vars.Var.loc var) - "Variable %a is not allowed in this context" - String_with_vars.Var.pp var - end - | Some (Right Ocaml_config) -> - String.Map.find t.ocaml_config (String_with_vars.Var.name var) - | Some (Right _) -> - Loc.fail (String_with_vars.Var.loc var) - "This percent form isn't allowed in this position") + String_with_vars.expand ~mode:Single ~dir s ~f:(fun pform syntax_version -> + match + match Pform.Map.expand bindings ~syntax_version ~pform with + | None -> Pform.Map.expand t.pforms ~syntax_version ~pform + | Some _ as x -> x + with + | None -> None + | Some x -> + match x with + | Values l -> Some l + | Ocaml_config -> Some (expand_ocaml_config t pform) + | Project_root -> Some [Value.Dir (Scope.root scope)] + | _ -> + Loc.fail (String_with_vars.Var.loc pform) + "%s isn't allowed in this position" + (String_with_vars.Var.describe pform)) in let expand_vars t ~scope ~dir ?bindings s = expand t ~scope ~dir ?bindings s @@ -308,7 +288,7 @@ let create List.filter context.ocamlc_cflags ~f:(fun s -> not (String.is_prefix s ~prefix:"-std=")) in - let vars = Pform.Map.create_vars ~context ~cxx_flags in + let pforms = Pform.Map.create ~context ~cxx_flags in let ocaml_config = let string s = [Value.String s] in Ocaml_config.to_list context.ocaml_config @@ -335,8 +315,7 @@ let create ; stanzas_to_consider_for_install ; artifacts ; cxx_flags - ; vars - ; macros = Pform.Map.macros + ; pforms ; ocaml_config ; chdir = Build.arr (fun (action : Action.t) -> match action with @@ -640,126 +619,119 @@ module Action = struct ; ddeps = String.Map.empty } in - let expand_form s var syntax_version = - let loc = String_with_vars.Var.loc var in - let key = String_with_vars.Var.full_name var in - begin match expand_macro sctx ~syntax_version ~var with - | Some Pform.Macro.Exe -> Some (path_exp (map_exe (Path.relative dir s))) - | Some Ocaml_config -> String.Map.find sctx.ocaml_config s - | Some Dep -> Some (path_exp (Path.relative dir s)) - | Some Bin -> begin - let sctx = host sctx in - match Artifacts.binary (artifacts sctx) s with - | Ok path -> Some (path_exp path) - | Error e -> - add_fail acc ({ fail = fun () -> Action.Prog.Not_found.raise e }) - end - | Some Lib -> begin - let lib_dep, file = parse_lib_file ~loc s in - add_lib_dep acc lib_dep dep_kind; - match - Artifacts.file_of_lib (artifacts sctx) ~loc ~lib:lib_dep ~file - with - | Ok path -> Some (path_exp path) - | Error fail -> add_fail acc fail - end - | Some Libexec -> begin - let sctx = host sctx in - let lib_dep, file = parse_lib_file ~loc s in - add_lib_dep acc lib_dep dep_kind; - match - Artifacts.file_of_lib (artifacts sctx) ~loc ~lib:lib_dep ~file - with - | Error fail -> add_fail acc fail - | Ok path -> - if not Sys.win32 || Filename.extension s = ".exe" then begin - Some (path_exp path) - end else begin - let path_exe = Path.extend_basename path ~suffix:".exe" in - let dep = - Build.if_file_exists path_exe - ~then_:(Build.path path_exe >>^ fun _ -> path_exp path_exe) - ~else_:(Build.path path >>^ fun _ -> path_exp path) - in - add_ddep acc ~key dep - end - end - | Some Lib_available -> begin - let lib = s in - add_lib_dep acc lib Optional; - Some (str_exp (string_of_bool ( - Lib.DB.available (Scope.libs scope) lib))) - end - | Some Version -> begin - match Package.Name.Map.find (Scope.project scope).packages - (Package.Name.of_string s) with - | Some p -> - let x = - Pkg_version.read sctx p >>^ function - | None -> [Value.String ""] - | Some s -> [String s] - in - add_ddep acc ~key x - | None -> - add_fail acc { fail = fun () -> - Loc.fail loc "Package %S doesn't exist in the current project." s - } - end - | Some Read -> begin - let path = Path.relative dir s in - let data = - Build.contents path - >>^ fun s -> [Value.String s] - in - add_ddep acc ~key data - end - | Some Read_lines -> begin - let path = Path.relative dir s in - let data = - Build.lines_of path - >>^ Value.L.strings - in - add_ddep acc ~key data - end - | Some Read_strings -> begin - let path = Path.relative dir s in - let data = - Build.strings path - >>^ Value.L.strings - in - add_ddep acc ~key data - end - | Some Path_no_dep -> Some [Value.Dir (Path.relative dir s)] - | None -> - Loc.fail (String_with_vars.Var.loc var) "Unknown form: %a" - String_with_vars.Var.pp var - end - in - let expand var syntax_version = - let loc = String_with_vars.Var.loc var in + let expand pform syntax_version = + let loc = String_with_vars.Var.loc pform in + let key = String_with_vars.Var.full_name pform in + let s = Option.value (String_with_vars.Var.payload pform) ~default:"" in let res = - match String_with_vars.Var.destruct var with - | Macro (_, s) -> expand_form s var syntax_version - | Var var_name -> - begin match Pform.Map.expand bindings ~syntax_version ~var with - | None -> None - | Some Pform.Var.Targets -> - let var () = - match var_name with - | "@" -> sprintf "${%s}" var_name - | "targets" -> sprintf "%%{%s}" var_name - | _ -> assert false - in + match Pform.Map.expand bindings ~syntax_version ~pform with + | None -> None + | Some x -> + match x with + | Values l -> Some l + | Ocaml_config -> Some (expand_ocaml_config sctx pform) + | Project_root -> Some [Value.Dir (Scope.root scope)] + | First_dep | Deps | Named_local -> None + | Targets -> begin match targets_written_by_user with | Infer -> - Loc.fail loc "You cannot use %s with inferred rules." (var ()) + Loc.fail loc "You cannot use %s with inferred rules." + (String_with_vars.Var.describe pform) | Alias -> - Loc.fail loc "You cannot use %s in aliases." (var ()) + Loc.fail loc "You cannot use %s in aliases." + (String_with_vars.Var.describe pform) | Static l -> Some (Value.L.dirs l) (* XXX hack to signal no dep *) end - | Some v -> Pform.Var.to_value_no_deps_or_targets v ~scope - end + | Exe -> Some (path_exp (map_exe (Path.relative dir s))) + | Dep -> Some (path_exp (Path.relative dir s)) + | Bin -> begin + let sctx = host sctx in + match Artifacts.binary (artifacts sctx) s with + | Ok path -> Some (path_exp path) + | Error e -> + add_fail acc + ({ fail = fun () -> Action.Prog.Not_found.raise e }) + end + | Lib -> begin + let lib_dep, file = parse_lib_file ~loc s in + add_lib_dep acc lib_dep dep_kind; + match + Artifacts.file_of_lib (artifacts sctx) ~loc ~lib:lib_dep ~file + with + | Ok path -> Some (path_exp path) + | Error fail -> add_fail acc fail + end + | Libexec -> begin + let sctx = host sctx in + let lib_dep, file = parse_lib_file ~loc s in + add_lib_dep acc lib_dep dep_kind; + match + Artifacts.file_of_lib (artifacts sctx) ~loc ~lib:lib_dep ~file + with + | Error fail -> add_fail acc fail + | Ok path -> + if not Sys.win32 || Filename.extension s = ".exe" then begin + Some (path_exp path) + end else begin + let path_exe = Path.extend_basename path ~suffix:".exe" in + let dep = + Build.if_file_exists path_exe + ~then_:(Build.path path_exe >>^ fun _ -> + path_exp path_exe) + ~else_:(Build.path path >>^ fun _ -> + path_exp path) + in + add_ddep acc ~key dep + end + end + | Lib_available -> begin + let lib = s in + add_lib_dep acc lib Optional; + Some (str_exp (string_of_bool ( + Lib.DB.available (Scope.libs scope) lib))) + end + | Version -> begin + match Package.Name.Map.find (Scope.project scope).packages + (Package.Name.of_string s) with + | Some p -> + let x = + Pkg_version.read sctx p >>^ function + | None -> [Value.String ""] + | Some s -> [String s] + in + add_ddep acc ~key x + | None -> + add_fail acc { fail = fun () -> + Loc.fail loc + "Package %S doesn't exist in the current project." s + } + end + | Read -> begin + let path = Path.relative dir s in + let data = + Build.contents path + >>^ fun s -> [Value.String s] + in + add_ddep acc ~key data + end + | Read_lines -> begin + let path = Path.relative dir s in + let data = + Build.lines_of path + >>^ Value.L.strings + in + add_ddep acc ~key data + end + | Read_strings -> begin + let path = Path.relative dir s in + let data = + Build.strings path + >>^ Value.L.strings + in + add_ddep acc ~key data + end + | Path_no_dep -> Some [Value.Dir (Path.relative dir s)] in Option.iter res ~f:(fun v -> acc.sdeps <- Path.Set.union @@ -770,23 +742,31 @@ module Action = struct let t = U.partial_expand t ~dir ~map_exe ~f:expand in (t, acc) - let expand_step2 ~dir ~dynamic_expansions + let expand_step2 ~dir ~dynamic_expansions ~bindings ~(deps_written_by_user : Path.t Jbuild.Bindings.t) ~map_exe t = - U.Partial.expand t ~dir ~map_exe ~f:(fun var syntax_version -> - let key = String_with_vars.Var.full_name var in - let loc = String_with_vars.Var.loc var in + U.Partial.expand t ~dir ~map_exe ~f:(fun pform syntax_version -> + let key = String_with_vars.Var.full_name pform in + let loc = String_with_vars.Var.loc pform in match String.Map.find dynamic_expansions key with | Some _ as opt -> opt | None -> match - Pform.Map.expand Pform.Map.static_vars ~syntax_version ~var + Pform.Map.expand bindings ~syntax_version ~pform with - | None -> - Jbuild.Bindings.find deps_written_by_user key - |> Option.map ~f:Value.L.paths + | None -> None | Some x -> match x with + | Named_local -> + begin match Jbuild.Bindings.find deps_written_by_user key with + | None -> + Exn.code_error "Local named variable not present in named deps" + [ "pform", String_with_vars.Var.sexp_of_t pform + ; "deps_written_by_user", + Jbuild.Bindings.sexp_of_t Path.sexp_of_t deps_written_by_user + ] + | Some x -> Some (Value.L.paths x) + end | Deps -> deps_written_by_user |> Jbuild.Bindings.to_list @@ -807,11 +787,12 @@ module Action = struct end | _ -> Exn.code_error "Unexpected variable in step2" - ["var", String_with_vars.Var.sexp_of_t var]) + ["var", String_with_vars.Var.sexp_of_t pform]) let run sctx ~loc ~bindings t ~dir ~dep_kind ~targets:targets_written_by_user ~scope : (Path.t Bindings.t, Action.t) Build.t = + let bindings = Pform.Map.superpose sctx.pforms bindings in let map_exe = map_exe sctx in if targets_written_by_user = Alias then begin match Action.Infer.unexpanded_targets t with @@ -823,7 +804,6 @@ module Action = struct This will become an error in the future."; end; let t, forms = - let bindings = Pform.Map.superpose sctx.vars bindings in expand_step1 sctx t ~dir ~dep_kind ~scope ~targets_written_by_user ~map_exe ~bindings in @@ -884,6 +864,7 @@ module Action = struct in let unresolved = expand_step2 t ~dir ~dynamic_expansions ~deps_written_by_user ~map_exe + ~bindings in Action.Unresolved.resolve unresolved ~f:(fun prog -> let sctx = host sctx in diff --git a/src/super_context.mli b/src/super_context.mli index 913ab515..2dd5db94 100644 --- a/src/super_context.mli +++ b/src/super_context.mli @@ -82,7 +82,7 @@ val expand_vars_string : t -> scope:Scope.t -> dir:Path.t - -> ?bindings:Pform.Var.t Pform.Map.t + -> ?bindings:Pform.Map.t -> String_with_vars.t -> string @@ -90,7 +90,7 @@ val expand_vars_path : t -> scope:Scope.t -> dir:Path.t - -> ?bindings:Pform.Var.t Pform.Map.t + -> ?bindings:Pform.Map.t -> String_with_vars.t -> Path.t @@ -98,7 +98,7 @@ val expand_and_eval_set : t -> scope:Scope.t -> dir:Path.t - -> ?bindings:Pform.Var.t Pform.Map.t + -> ?bindings:Pform.Map.t -> Ordered_set_lang.Unexpanded.t -> standard:(unit, string list) Build.t -> (unit, string list) Build.t @@ -239,7 +239,7 @@ module Action : sig val run : t -> loc:Loc.t - -> bindings:Pform.Var.t Pform.Map.t + -> bindings:Pform.Map.t -> Action.Unexpanded.t -> dir:Path.t -> dep_kind:Build.lib_dep_kind diff --git a/test/blackbox-tests/test-cases/macro-expand-error/run.t b/test/blackbox-tests/test-cases/macro-expand-error/run.t index 99d53da5..fa71fdb2 100644 --- a/test/blackbox-tests/test-cases/macro-expand-error/run.t +++ b/test/blackbox-tests/test-cases/macro-expand-error/run.t @@ -4,5 +4,5 @@ inappropariate place: $ dune build Info: creating file dune-project with this contents: (lang dune 1.0) File "dune", line 1, characters 14-21: - Error: This percent form isn't allowed in this position + Error: %{read:..} isn't allowed in this position [1] From eb68a9067d64134c98b45e8e7ca4ab8e47cc1c6e Mon Sep 17 00:00:00 2001 From: Jeremie Dimino Date: Mon, 9 Jul 2018 18:47:55 +0100 Subject: [PATCH 27/34] Simplify Dep_conf.t Signed-off-by: Jeremie Dimino --- src/jbuild.ml | 44 +++++++++++++++++++++----------------------- 1 file changed, 21 insertions(+), 23 deletions(-) diff --git a/src/jbuild.ml b/src/jbuild.ml index eb1f05fa..6123df34 100644 --- a/src/jbuild.ml +++ b/src/jbuild.ml @@ -299,31 +299,29 @@ module Dep_conf = struct | Package of String_with_vars.t | Universe - let dep_cons = - let sw = String_with_vars.t in - [ "file" , (sw >>| fun x -> File x) - ; "alias" , (sw >>| fun x -> Alias x) - ; "alias_rec" , (sw >>| fun x -> Alias_rec x) - ; "glob_files" , (sw >>| fun x -> Glob_files x) - ; "package" , (sw >>| fun x -> Package x) - ; "universe" , return Universe - ; "files_recursively_in", - (Syntax.renamed_in Stanza.syntax (1, 0) ~to_:"source_tree" - >>= fun () -> - sw >>| fun x -> Source_tree x) - ; "source_tree", - (Syntax.since Stanza.syntax (1, 0) >>= fun () -> - sw >>| fun x -> Source_tree x) - ] - - let make_dep_parser ~single ~many = + let t = + let t = + let sw = String_with_vars.t in + sum + [ "file" , (sw >>| fun x -> File x) + ; "alias" , (sw >>| fun x -> Alias x) + ; "alias_rec" , (sw >>| fun x -> Alias_rec x) + ; "glob_files" , (sw >>| fun x -> Glob_files x) + ; "package" , (sw >>| fun x -> Package x) + ; "universe" , return Universe + ; "files_recursively_in", + (Syntax.renamed_in Stanza.syntax (1, 0) ~to_:"source_tree" + >>= fun () -> + sw >>| fun x -> Source_tree x) + ; "source_tree", + (Syntax.since Stanza.syntax (1, 0) >>= fun () -> + sw >>| fun x -> Source_tree x) + ] + in peek_exn >>= function | Template _ | Atom _ | Quoted_string _ -> - String_with_vars.t >>| fun x -> single (File x) - | List _ -> many - - let t = - make_dep_parser ~single:(fun x -> x) ~many:(sum dep_cons) + String_with_vars.t >>| fun x -> File x + | List _ -> t open Sexp let sexp_of_t = function From 77800e669eee14d3d026cc80df2d0858eaf76de8 Mon Sep 17 00:00:00 2001 From: Rudi Grinberg Date: Tue, 10 Jul 2018 01:07:32 +0700 Subject: [PATCH 28/34] Simplify pattern matching with monads Signed-off-by: Rudi Grinberg --- src/super_context.ml | 50 +++++++++++++++++--------------------------- 1 file changed, 19 insertions(+), 31 deletions(-) diff --git a/src/super_context.ml b/src/super_context.ml index 2da87520..17ddaf81 100644 --- a/src/super_context.ml +++ b/src/super_context.ml @@ -97,21 +97,17 @@ let expand_ocaml_config t pform = let (expand_vars_string, expand_vars_path) = let expand t ~scope ~dir ?(bindings=Pform.Map.empty) s = String_with_vars.expand ~mode:Single ~dir s ~f:(fun pform syntax_version -> - match - match Pform.Map.expand bindings ~syntax_version ~pform with - | None -> Pform.Map.expand t.pforms ~syntax_version ~pform - | Some _ as x -> x - with - | None -> None - | Some x -> - match x with - | Values l -> Some l - | Ocaml_config -> Some (expand_ocaml_config t pform) - | Project_root -> Some [Value.Dir (Scope.root scope)] + (match Pform.Map.expand bindings ~syntax_version ~pform with + | None -> Pform.Map.expand t.pforms ~syntax_version ~pform + | Some _ as x -> x) + |> Option.map ~f:(function + | Pform.Values l -> l + | Ocaml_config -> expand_ocaml_config t pform + | Project_root -> [Value.Dir (Scope.root scope)] | _ -> Loc.fail (String_with_vars.Var.loc pform) "%s isn't allowed in this position" - (String_with_vars.Var.describe pform)) + (String_with_vars.Var.describe pform))) in let expand_vars t ~scope ~dir ?bindings s = expand t ~scope ~dir ?bindings s @@ -624,13 +620,11 @@ module Action = struct let key = String_with_vars.Var.full_name pform in let s = Option.value (String_with_vars.Var.payload pform) ~default:"" in let res = - match Pform.Map.expand bindings ~syntax_version ~pform with - | None -> None - | Some x -> - match x with - | Values l -> Some l - | Ocaml_config -> Some (expand_ocaml_config sctx pform) - | Project_root -> Some [Value.Dir (Scope.root scope)] + Pform.Map.expand bindings ~syntax_version ~pform + |> Option.bind ~f:(function + | Pform.Values l -> Some l + | Ocaml_config -> Some (expand_ocaml_config sctx pform) + | Project_root -> Some [Value.Dir (Scope.root scope)] | First_dep | Deps | Named_local -> None | Targets -> begin match targets_written_by_user with @@ -731,7 +725,7 @@ module Action = struct in add_ddep acc ~key data end - | Path_no_dep -> Some [Value.Dir (Path.relative dir s)] + | Path_no_dep -> Some [Value.Dir (Path.relative dir s)]) in Option.iter res ~f:(fun v -> acc.sdeps <- Path.Set.union @@ -751,12 +745,7 @@ module Action = struct match String.Map.find dynamic_expansions key with | Some _ as opt -> opt | None -> - match - Pform.Map.expand bindings ~syntax_version ~pform - with - | None -> None - | Some x -> - match x with + Option.map (Pform.Map.expand bindings ~syntax_version ~pform) ~f:(function | Named_local -> begin match Jbuild.Bindings.find deps_written_by_user key with | None -> @@ -765,13 +754,12 @@ module Action = struct ; "deps_written_by_user", Jbuild.Bindings.sexp_of_t Path.sexp_of_t deps_written_by_user ] - | Some x -> Some (Value.L.paths x) + | Some x -> Value.L.paths x end | Deps -> deps_written_by_user |> Jbuild.Bindings.to_list |> Value.L.paths - |> Option.some | First_dep -> begin match deps_written_by_user with | Named _ :: _ -> @@ -779,15 +767,15 @@ module Action = struct files and named dependencies are not available in jbuild files *) assert false - | Unnamed v :: _ -> Some [Path v] + | Unnamed v :: _ -> [Path v] | [] -> Loc.warn loc "Variable '%s' used with no explicit \ dependencies@." key; - Some [Value.String ""] + [Value.String ""] end | _ -> Exn.code_error "Unexpected variable in step2" - ["var", String_with_vars.Var.sexp_of_t pform]) + ["var", String_with_vars.Var.sexp_of_t pform])) let run sctx ~loc ~bindings t ~dir ~dep_kind ~targets:targets_written_by_user ~scope From 03f134567d51a6c67336a4880df8fd08569610e4 Mon Sep 17 00:00:00 2001 From: Rudi Grinberg Date: Tue, 10 Jul 2018 01:14:02 +0700 Subject: [PATCH 29/34] Update documentation for new binding names Signed-off-by: Rudi Grinberg --- doc/dune-files.rst | 45 ++++++++++++++++++++++----------------------- doc/tests.rst | 2 +- 2 files changed, 23 insertions(+), 24 deletions(-) diff --git a/doc/dune-files.rst b/doc/dune-files.rst index 9fd9a61e..d3eaa935 100644 --- a/doc/dune-files.rst +++ b/doc/dune-files.rst @@ -22,7 +22,7 @@ Stanzas (rule (targets foo.ml) (deps generator/gen.exe) - (action (run %{<} -o %{@}))) + (action (run %{deps} -o %{targets}))) The following sections describe the available stanzas and their meaning. @@ -459,7 +459,7 @@ For instance: (rule (targets b (deps a - (action (copy %{<} %{@}))))) + (action (copy %{deps} %{targets}))))) In this example it is obvious by inspecting the action what the dependencies and targets are. When this is the case you can use the @@ -495,7 +495,7 @@ ocamllex (rule (targets .ml) (deps .mll) - (action (chdir %{root} (run %{bin:ocamllex} -q -o %{<})))) + (action (chdir %{root} (run %{bin:ocamllex} -q -o %{targets} %{deps})))) To use a different rule mode, use the long form: @@ -515,7 +515,7 @@ ocamlyacc (rule (targets .ml .mli) (deps .mly) - (action (chdir %{root} (run %{bin:ocamlyacc} %{<})))) + (action (chdir %{root} (run %{bin:ocamlyacc} %{deps})))) To use a different rule mode, use the long form: @@ -866,9 +866,8 @@ Dune supports the following variables: In addition, ``(action ...)`` fields support the following special variables: -- ``@`` expands to the list of target -- ``<`` expands to the first dependency, or the empty string if there are no - dependencies +- ``targets`` expands to the list of target +- ``deps`` expands to the list of dependencies - ``^`` expands to the list of dependencies, separated by spaces - ``dep:`` expands to ```` (and adds ```` as a dependency of the action) @@ -909,7 +908,7 @@ In addition, ``(action ...)`` fields support the following special variables: The ``%{:...}`` forms are what allows you to write custom rules that work transparently whether things are installed or not. -Note that aliases are ignored by both ``%{<}`` and ``%{^}``. +Note that aliases are ignored by ``%{deps}`` The intent of this last form is to reliably read a list of strings generated by an OCaml program via: @@ -920,13 +919,13 @@ generated by an OCaml program via: #. Expansion of lists -Forms that expands to list of items, such as ``%{cc}``, ``%{^}``, -``%{@}`` or ``%{read-lines:...}``, are suitable to be used in, say, +Forms that expands to list of items, such as ``%{cc}``, ``%{deps}``, +``%{targets}`` or ``%{read-lines:...}``, are suitable to be used in, say, ``(run )``. For instance in: .. code:: scheme - (run foo %{^}) + (run foo %{deps}) if there are two dependencies ``a`` and ``b``, the produced command will be equivalent to the shell command: @@ -940,7 +939,7 @@ you have to quote the variable as in: .. code:: scheme - (run foo "%{^}") + (run foo "%{deps}") which is equivalent to the following shell command: @@ -949,7 +948,7 @@ which is equivalent to the following shell command: $ foo "a b" (the items of the list are concatenated with space). -Note that, since ``%{^}`` is a list of items, the first one may be +Note that, since ``%{deps}`` is a list of items, the first one may be used as a program name, for instance: .. code:: scheme @@ -957,7 +956,7 @@ used as a program name, for instance: (rule (targets result.txt) (deps foo.exe (glob_files *.txt)) - (action (run %{^}))) + (action (run %{deps}))) Here is another example: @@ -966,7 +965,7 @@ Here is another example: (rule (targets foo.exe) (deps foo.c) - (action (run %{cc} -o %{@} %{<} -lfoolib))) + (action (run %{cc} -o %{targets} %{deps} -lfoolib))) Library dependencies @@ -1052,7 +1051,7 @@ you had setup a rule for every file of the form: (rule (targets file.pp.ml) (deps file.ml) - (action (with-stdout-to %{@} (chdir %{root} )))) + (action (with-stdout-to %{targets} (chdir %{root} )))) The equivalent of a ``-pp `` option passed to the OCaml compiler is ``(system " %{input-file}")``. @@ -1105,8 +1104,8 @@ For instance: .. code:: scheme (preprocess (per_module - (((action (run ./pp.sh X=1 %{<})) (foo bar))) - (((action (run ./pp.sh X=2 %{<})) (baz))))) + (((action (run ./pp.sh X=1 %{input-file})) (foo bar))) + (((action (run ./pp.sh X=2 %{input-file})) (baz))))) .. _deps-field: @@ -1310,7 +1309,7 @@ To understand why this is important, let's consider this dune file living in (rule (targets blah.ml) (deps blah.mll) - (action (run ocamllex -o %{@} %{<}))) + (action (run ocamllex -o %{targets} %{deps}))) Here the command that will be executed is: @@ -1334,7 +1333,7 @@ of your project. What you should write instead is: (rule (targets blah.ml) (deps blah.mll) - (action (chdir %{root} (run ocamllex -o %{@} %{<})))) + (action (chdir %{root} (run ocamllex -o %{targets} %{deps})))) Locks ----- @@ -1357,13 +1356,13 @@ same lock: (name runtest) (deps foo) (locks m) - (action (run test.exe %{<}))) + (action (run test.exe %{deps}))) (alias (name runtest) (deps bar) (locks m) - (action (run test.exe %{<}))) + (action (run test.exe %{deps}))) Dune will make sure that the executions of ``test.exe foo`` and ``test.exe bar`` are serialized. @@ -1383,7 +1382,7 @@ simply use an absolute filename: (name runtest) (deps foo) (locks /tcp-port/1042) - (action (run test.exe %{<}))) + (action (run test.exe %{deps}))) .. _ocaml-syntax: diff --git a/doc/tests.rst b/doc/tests.rst index c1ecd715..3ca4e15c 100644 --- a/doc/tests.rst +++ b/doc/tests.rst @@ -307,7 +307,7 @@ The backend for such a framework looks like this: (library ((name simple_tests) (inline_tests.backend - ((generate_runner (run sed "s/(\\*TEST:\\(.*\\)\\*)/let () = \\1;;/" ${impl-files})) + ((generate_runner (run sed "s/(\\*TEST:\\(.*\\)\\*)/let () = \\1;;/" %{impl-files})) )))) Now all you have to do is write ``(inline_tests ((backend From 61c189a6d46bbbac6b8c28015f2f08a37d8f390d Mon Sep 17 00:00:00 2001 From: Rudi Grinberg Date: Tue, 10 Jul 2018 01:18:09 +0700 Subject: [PATCH 30/34] Update CHANGES Signed-off-by: Rudi Grinberg --- CHANGES.md | 3 +++ 1 file changed, 3 insertions(+) diff --git a/CHANGES.md b/CHANGES.md index fc935879..f1d57256 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -143,6 +143,9 @@ next - Lowercase all built-in %{variables} in dune files (#956, @rgrinberg) +- New syntax for naming dependencies: `(deps (:x a b) (:y (glob_files *.c*)))`. + This replaces the use for `${<}` in dune files. (#950, @diml, @rgrinberg) + 1.0+beta20 (10/04/2018) ----------------------- From 5e55f3d6c5d604ff5cec2902d1dd6af341393388 Mon Sep 17 00:00:00 2001 From: Rudi Grinberg Date: Tue, 10 Jul 2018 01:19:19 +0700 Subject: [PATCH 31/34] Add some missing parens to the manual Signed-off-by: Rudi Grinberg --- doc/dune-files.rst | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/doc/dune-files.rst b/doc/dune-files.rst index d3eaa935..b832f6cf 100644 --- a/doc/dune-files.rst +++ b/doc/dune-files.rst @@ -457,9 +457,9 @@ For instance: .. code:: scheme (rule - (targets b - (deps a - (action (copy %{deps} %{targets}))))) + (targets b) + (deps a) + (action (copy %{deps} %{targets}))) In this example it is obvious by inspecting the action what the dependencies and targets are. When this is the case you can use the From 3866134ca3a904a62d7950648bae7537865701c6 Mon Sep 17 00:00:00 2001 From: Rudi Grinberg Date: Tue, 10 Jul 2018 01:31:45 +0700 Subject: [PATCH 32/34] Add docs for named deps Signed-off-by: Rudi Grinberg --- doc/dune-files.rst | 29 +++++++++++++++++++++++++++++ 1 file changed, 29 insertions(+) diff --git a/doc/dune-files.rst b/doc/dune-files.rst index b832f6cf..f50d4cbc 100644 --- a/doc/dune-files.rst +++ b/doc/dune-files.rst @@ -1115,6 +1115,8 @@ Dependency specification Dependencies in ``dune`` files can be specified using one of the following syntax: +- ``(:name )`` will bind the the list of dependencies to the + ``name`` variable. This variable will be available as ``%{name}`` in actions. - ``(file )`` or simply ````: depend on this file - ``(alias )``: depend on the construction of this alias, for instance: ``(alias src/runtest)`` @@ -1142,6 +1144,33 @@ syntax: In all these cases, the argument supports `Variables expansion`_. +Named Dependencies +~~~~~~~~~~~~~~~~~~ + +dune allows a user to organize dependency lists by naming them. The user is +allowed to assign a group of dependencies a name that can later be referred to +in actions (like the ``%{deps}`` and ``%{targets}`` built in variables). + +One instance where is useful is for naming globs. Here's an example of an +imaginary bundle command: + +.. code:: scheme + + (rule + (targets archive.tar) + (deps + index.html + (:css (glob_files *.css)) + (:js foo.js bar.js) + (:img (glob_files *.png) (glob_files *.jpg))) + (action + (run %{bin:bundle} index.html -css %{css} -js %{js} -img %{img} -o %{targets}))) + +Note that such named dependency list can also include unnamed dependencies (like +``index.html`` in the example above). Also, such user defined names wil shadow +built in variables. So ``(:root x)`` will shadow the built in ``%{root}`` +variable. + .. _glob: Glob From 2d59575a31374d3981aa7d8abe734938d35d05f9 Mon Sep 17 00:00:00 2001 From: Rudi Grinberg Date: Tue, 10 Jul 2018 01:47:18 +0700 Subject: [PATCH 33/34] Fix meaning of ${<} in jbuild files Signed-off-by: Rudi Grinberg --- src/pform.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/pform.ml b/src/pform.ml index 67a3270f..a3e3d6f5 100644 --- a/src/pform.ml +++ b/src/pform.ml @@ -40,7 +40,7 @@ module Map = struct ; "deps", since ~version:(1, 0) Deps ; "project_root", since ~version:(1, 0) Project_root - ; "<", deleted_in Deps ~version:(1, 0) + ; "<", deleted_in First_dep ~version:(1, 0) ~repl:"Use a named dependency instead:\ \n\ \n\ (deps (:x ) ...)\ From 80b3684f9f6ad08e9086122c0705a73cab2b8262 Mon Sep 17 00:00:00 2001 From: Rudi Grinberg Date: Tue, 10 Jul 2018 02:36:13 +0700 Subject: [PATCH 34/34] Make input-file backwards compatible Signed-off-by: Rudi Grinberg --- src/pform.ml | 7 +++++++ src/pform.mli | 4 ++++ src/preprocessing.ml | 14 ++++++-------- 3 files changed, 17 insertions(+), 8 deletions(-) diff --git a/src/pform.ml b/src/pform.ml index a3e3d6f5..ac1971fd 100644 --- a/src/pform.ml +++ b/src/pform.ml @@ -173,4 +173,11 @@ module Map = struct | Unnamed _ -> acc | Named (s, _) -> String.Map.add acc s (No_info Named_local) ) ~init:empty + + let input_file path = + let value = Values (Value.L.paths [path]) in + [ "input-file", since ~version:(1, 0) value + ; "<", renamed_in ~new_name:"input-file" ~version:(1, 0) + ] + |> String.Map.of_list_exn end diff --git a/src/pform.mli b/src/pform.mli index 471dab57..1135c594 100644 --- a/src/pform.mli +++ b/src/pform.mli @@ -1,3 +1,5 @@ +open Stdune + type t = (* Variables *) | Values of Value.t list @@ -36,6 +38,8 @@ module Map : sig val of_list_exn : (string * pform) list -> t + val input_file : Path.t -> t + val expand : t -> syntax_version:Syntax.Version.t diff --git a/src/preprocessing.ml b/src/preprocessing.ml index 904694ac..5961de93 100644 --- a/src/preprocessing.ml +++ b/src/preprocessing.ml @@ -454,18 +454,16 @@ let lint_module sctx ~dir ~dep_kind ~lint ~lib_name ~scope ~dir_kind = let action = Action.Unexpanded.Chdir (root_var, action) in Module.iter source ~f:(fun _ (src : Module.File.t) -> let src_path = Path.relative dir src.name in - let bindings = - [Jbuild.Bindings.Named ("input-file", [src_path])] - in + let bindings = Pform.Map.input_file src_path in add_alias src.name (Build.path src_path - >>^ (fun _ -> bindings) + >>^ (fun _ -> Jbuild.Bindings.empty) >>> SC.Action.run sctx action ~loc ~dir ~dep_kind - ~bindings:(Pform.Map.of_bindings bindings) + ~bindings ~targets:(Static []) ~scope))) | Pps { loc; pps; flags } -> @@ -532,12 +530,12 @@ let make sctx ~dir ~dep_kind ~lint ~preprocess (fun m ~lint -> let ast = pped_module m ~dir ~f:(fun _kind src dst -> - let bindings = [Jbuild.Bindings.Named ("input-file", [src])] in + let bindings = Pform.Map.input_file src in SC.add_rule sctx (preprocessor_deps >>> Build.path src - >>^ (fun _ -> bindings) + >>^ (fun _ -> Jbuild.Bindings.empty) >>> SC.Action.run sctx (Redirect @@ -548,7 +546,7 @@ let make sctx ~dir ~dep_kind ~lint ~preprocess ~loc ~dir ~dep_kind - ~bindings:(Pform.Map.of_bindings bindings) + ~bindings ~targets:(Static [dst]) ~scope)) |> setup_reason_rules sctx ~dir in