From bfc1b9fd25c4bf24d3fdd52a1faee28fbcdbea88 Mon Sep 17 00:00:00 2001 From: Rudi Grinberg Date: Mon, 9 Jul 2018 22:26:40 +0700 Subject: [PATCH] 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