fix: merge for Module_trie

Signed-off-by: Antonio Nuno Monteiro <anmonteiro@gmail.com>
ocaml · May 24, 2023 · 1e08518 · 1e08518
1 parent f80d2ba
commit 1e08518
Show file tree

Hide file tree

Showing 2 changed files with 41 additions and 93 deletions.
diff --git a/src/dune_rules/module_trie.ml b/src/dune_rules/module_trie.ml
@@ -103,14 +103,24 @@ let rec to_dyn f t =
     t
 
 let merge x y ~f =
-  let base _path _ = (* TODO *) assert false in
+  let rec base ~path ~f t =
+    Map.foldi t ~init:empty ~f:(fun k v acc ->
+        let path = k :: path in
+        let rev_path = List.rev path in
+        match v with
+        | Leaf leaf -> (
+          match f rev_path leaf with
+          | None -> acc
+          | Some leaf -> Map.add_exn acc k (Leaf leaf))
+        | Map m -> Map.add_exn acc k (Map (base ~path ~f m)))
+  in
   let rec loop path x y =
     match (x, y) with
     | None, None -> assert false
-    | Some x, None -> base path x
-    | None, Some x -> base path x
+    | Some x, None -> base x ~path ~f:(fun path x -> f path (Some x) None)
+    | None, Some y -> base y ~path ~f:(fun path x -> f path None (Some x))
     | Some x, Some y ->
-      Map.merge x y ~f:(fun name x y ->
+      Map.merge x y ~f:(fun (name : Module_name.t) x y ->
           let path = name :: path in
           let rev_path = List.rev path in
           let leaf l r =
@@ -125,8 +135,10 @@ let merge x y ~f =
           | Some (Leaf x), None -> leaf (Some x) None
           | Some (Leaf x), Some (Leaf y) -> leaf (Some x) (Some y)
           (* maps *)
-          | None, Some (Map v) -> non_empty_map (base path v)
-          | Some (Map v), None -> non_empty_map (base path v)
+          | None, Some (Map v) ->
+            non_empty_map (base v ~path ~f:(fun path x -> f path None (Some x)))
+          | Some (Map v), None ->
+            non_empty_map (base v ~path ~f:(fun path x -> f path (Some x) None))
           | Some (Map x), Some (Map y) ->
             non_empty_map (loop path (Some x) (Some y))
           (* mixed *)

diff --git a/test/blackbox-tests/test-cases/include-qualified/merge.t/run.t b/test/blackbox-tests/test-cases/include-qualified/merge.t/run.t
@@ -2,92 +2,28 @@ Demonstrate building a `include_subdirs qualified` project with `(modules
 :standard \ exclusion)`
 
   $ dune build
-  File "src/dune_rules/module_trie.ml", line 106, characters 32-38:
-  File "src/dune_rules/module_trie.ml", line 106, characters 32-38: Assertion
-  failed
-  Raised at Dune_rules__Module_trie.merge.base in file
-    "src/dune_rules/module_trie.ml", line 106, characters 32-44
-  Called from Dune_rules__Module_trie.merge.loop.(fun) in file
-    "src/dune_rules/module_trie.ml", line 128, characters 48-61
-  Called from Stdlib__Map.Make.merge in file "map.ml", line 398, characters
-    44-63
-  Called from Stdlib__Map.Make.merge in file "map.ml", line 398, characters
-    64-79
-  Called from Stdlib__List.fold_left in file "list.ml", line 121, characters
-    24-34
-  Called from Dune_lang__Ordered_set_lang.Eval.of_ast.loop in file
-    "src/dune_lang/ordered_set_lang.ml", line 139, characters 19-28
-  Called from Dune_rules__Modules_field_evaluator.eval.(fun) in file
-    "src/dune_rules/modules_field_evaluator.ml", line 44, characters 18-62
-  Called from Dune_rules__Modules_field_evaluator.eval0 in file
-    "src/dune_rules/modules_field_evaluator.ml" (inlined), line 289, characters
-    13-60
-  Called from Dune_rules__Modules_field_evaluator.eval0 in file
-    "src/dune_rules/modules_field_evaluator.ml", line 290, characters 16-56
-  Called from Dune_rules__Modules_field_evaluator.eval in file
-    "src/dune_rules/modules_field_evaluator.ml", line 360, characters 4-105
-  Called from Dune_rules__Ml_sources.make_lib_modules in file
-    "src/dune_rules/ml_sources.ml", line 342, characters 4-197
-  Called from Fiber__Scheduler.exec in file "otherlibs/fiber/src/scheduler.ml",
-    line 73, characters 8-11
-  Re-raised at Stdune__Exn.raise_with_backtrace in file
-    "otherlibs/stdune/src/exn.ml", line 36, characters 27-56
-  Called from Fiber__Scheduler.exec in file "otherlibs/fiber/src/scheduler.ml",
-    line 73, characters 8-11
-  Re-raised at Stdune__Exn.raise_with_backtrace in file
-    "otherlibs/stdune/src/exn.ml", line 36, characters 27-56
-  Called from Fiber__Scheduler.exec in file "otherlibs/fiber/src/scheduler.ml",
-    line 73, characters 8-11
-  Re-raised at Stdune__Exn.raise_with_backtrace in file
-    "otherlibs/stdune/src/exn.ml", line 36, characters 27-56
-  Called from Fiber__Scheduler.exec in file "otherlibs/fiber/src/scheduler.ml",
-    line 73, characters 8-11
-  Re-raised at Stdune__Exn.raise_with_backtrace in file
-    "otherlibs/stdune/src/exn.ml", line 36, characters 27-56
-  Called from Fiber__Scheduler.exec in file "otherlibs/fiber/src/scheduler.ml",
-    line 73, characters 8-11
-  Re-raised at Stdune__Exn.raise_with_backtrace in file
-    "otherlibs/stdune/src/exn.ml", line 36, characters 27-56
-  Called from Fiber__Scheduler.exec in file "otherlibs/fiber/src/scheduler.ml",
-    line 73, characters 8-11
-  Re-raised at Stdune__Exn.raise_with_backtrace in file
-    "otherlibs/stdune/src/exn.ml", line 36, characters 27-56
-  Called from Fiber__Scheduler.exec in file "otherlibs/fiber/src/scheduler.ml",
-    line 73, characters 8-11
-  Re-raised at Stdune__Exn.raise_with_backtrace in file
-    "otherlibs/stdune/src/exn.ml", line 36, characters 27-56
-  Called from Fiber__Scheduler.exec in file "otherlibs/fiber/src/scheduler.ml",
-    line 73, characters 8-11
-  Re-raised at Stdune__Exn.raise_with_backtrace in file
-    "otherlibs/stdune/src/exn.ml", line 36, characters 27-56
-  Called from Fiber__Scheduler.exec in file "otherlibs/fiber/src/scheduler.ml",
-    line 73, characters 8-11
-  Re-raised at Stdune__Exn.raise_with_backtrace in file
-    "otherlibs/stdune/src/exn.ml", line 36, characters 27-56
-  Called from Fiber__Scheduler.exec in file "otherlibs/fiber/src/scheduler.ml",
-    line 73, characters 8-11
-  Re-raised at Stdune__Exn.raise_with_backtrace in file
-    "otherlibs/stdune/src/exn.ml", line 36, characters 27-56
-  Called from Fiber__Scheduler.exec in file "otherlibs/fiber/src/scheduler.ml",
-    line 73, characters 8-11
-  Re-raised at Stdune__Exn.raise_with_backtrace in file
-    "otherlibs/stdune/src/exn.ml", line 36, characters 27-56
-  Called from Fiber__Scheduler.exec in file "otherlibs/fiber/src/scheduler.ml",
-    line 73, characters 8-11
-  Re-raised at Stdune__Exn.raise_with_backtrace in file
-    "otherlibs/stdune/src/exn.ml", line 36, characters 27-56
-  Called from Fiber__Scheduler.exec in file "otherlibs/fiber/src/scheduler.ml",
-    line 73, characters 8-11
-  Re-raised at Stdune__Exn.raise_with_backtrace in file
-    "otherlibs/stdune/src/exn.ml", line 36, characters 27-56
-  Called from Fiber__Scheduler.exec in file "otherlibs/fiber/src/scheduler.ml",
-    line 73, characters 8-11
-
-  I must not crash.  Uncertainty is the mind-killer. Exceptions are the
-  little-death that brings total obliteration.  I will fully express my cases.
-  Execution will pass over me and through me.  And when it has gone past, I
-  will unwind the stack along its path.  Where the cases are handled there will
-  be nothing.  Only I will remain.
-  [1]
+  hello from nested module bar
+  hello from nested module B
 
   $ find _build -iname "*.ml-gen" | sort | while read file; do echo "contents of $file"; cat $file; echo "--------"; done;
+  contents of _build/default/lib/foolib.ml-gen
+  (* generated by dune *)
+
+  (** @canonical Foolib.Foo *)
+  module Foo = Foolib__Foo
+  --------
+  contents of _build/default/lib/foolib__Foo.ml-gen
+  (* generated by dune *)
+
+  (** @canonical Foolib.Foo.A *)
+  module A = Foolib__Foo__A
+
+  (** @canonical Foolib.Foo.Bar *)
+  module Bar = Foolib__Foo__Bar
+  --------
+  contents of _build/default/lib/foolib__Foo__A.ml-gen
+  (* generated by dune *)
+
+  (** @canonical Foolib.Foo.A.B *)
+  module B = Foolib__Foo__A__B
+  --------