fix: correctly handle absolute paths in dune ocaml top-module

Signed-off-by: Ali Caglayan <alizter@gmail.com>
ocaml · Jul 24, 2023 · 96769ee · 96769ee
1 parent cb3489d
commit 96769ee
Show file tree

Hide file tree

Showing 3 changed files with 33 additions and 13 deletions.
diff --git a/CHANGES.md b/CHANGES.md
@@ -21,6 +21,9 @@ Unreleased
 - Improve `dune describe external-lib-deps` by adding the internal dependencies
   for more information. (#7478, @moyodiallo)
 
+- Fix `dune ocaml top-module` to correctly handle absolute paths. (#8249, fixes
+  #7370, @Alizter)
+
 - Fix permission errors when `sendfile` is not available (#8234, fixes #8120,
   @emillon)
 

diff --git a/bin/ocaml/top.ml b/bin/ocaml/top.ml
@@ -207,7 +207,10 @@ module Module = struct
   let term =
     let+ common = Common.term
     and+ module_path =
-      Arg.(required & pos 0 (some string) None & Arg.info [] ~docv:"MODULE")
+      Arg.(
+        required
+        & pos 0 (some string) None
+        & Arg.info [] ~docv:"MODULE" ~doc:"Path to an OCaml module.")
     and+ ctx_name =
       Common.context_arg ~doc:{|Select context where to build/run utop.|}
     in
@@ -224,11 +227,24 @@ module Module = struct
             in
             let+ directives =
               let module_path =
-                let root = Common.root common in
-                Path.Source.relative Path.Source.root
-                  (root.reach_from_root_prefix ^ module_path)
+                if Filename.is_relative module_path then
+                  Path.Local.of_string module_path
+                else
+                  let root =
+                    (Common.root common).dir |> Path.of_string
+                    |> Path.to_absolute_filename |> Path.of_string
+                  in
+                  match
+                    Path.drop_prefix ~prefix:root (Path.of_string module_path)
+                  with
+                  | Some module_path -> module_path
+                  | None ->
+                    User_error.raise
+                      [ Pp.text
+                          "Module path not a descendent of workspace root."
+                      ]
               in
-              module_directives sctx module_path
+              module_directives sctx (Path.Source.of_local module_path)
             in
             Dune_rules.Toplevel.print_toplevel_init_file directives))
 end

diff --git a/test/blackbox-tests/test-cases/top-module/load-from-lib.t b/test/blackbox-tests/test-cases/top-module/load-from-lib.t
@@ -57,11 +57,12 @@ We try to load a module defined in a library with a dependnecy
   $ ls _build/default/mydummylib/*.cma
   _build/default/mydummylib/mydummylib.cma
 
-  $ dune ocaml top-module $PWD/foo/foo.ml 2>&1 | head -n7
-  Internal error, please report upstream including the contents of _build/log.
-  Description:
-    ("Local.relative: received absolute path",
-    { t = "."
-    ; path =
-        "$TESTCASE_ROOT/foo/foo.ml"
-    })
+  $ dune ocaml top-module $PWD/foo/foo.ml
+  #directory "$TESTCASE_ROOT/_build/default/.topmod/foo/foo.ml";;
+  #directory "$TESTCASE_ROOT/_build/default/mydummylib/.mydummylib.objs/byte";;
+  #load "$TESTCASE_ROOT/_build/default/mydummylib/mydummylib.cma";;
+  #load "$TESTCASE_ROOT/_build/default/foo/.foo.objs/byte/foo__.cmo";;
+  #load "$TESTCASE_ROOT/_build/default/foo/.foo.objs/byte/foo__Bar.cmo";;
+  #load "$TESTCASE_ROOT/_build/default/.topmod/foo/foo.ml/foo.cmo";;
+  open Foo__
+  ;;