Change binding representation to use a list

This preserves the order of things

Signed-off-by: Rudi Grinberg <rudi.grinberg@gmail.com>

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

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
 

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 ->

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
 

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