Improve implementation of external to source mapping

Signed-off-by: Marek Kubica <[email protected]>

Author: Leonidas-from-XIV

src/dune_pkg/workspace.ml

@@ -72,35 +72,33 @@ module Repository = struct
 end
 
 let dev_tool_path_to_source_dir path =
-  let of_ =
-    Path.Build.relative Path.Build.root ".dev-tools.locks"
-    |> Path.build
-    |> Path.to_absolute_filename
-    |> Path.External.of_string
+  let lock_dir_location =
+    Path.Build.relative Path.Build.root ".dev-tools.locks" |> Path.build
   in
-  let in_dev_tool_dir = Path.External.is_descendant ~of_ path in
-  match in_dev_tool_dir with
+  let absolute = Path.to_absolute_filename lock_dir_location in
+  match Path.External.is_descendant ~of_:(Path.External.of_string absolute) path with
   | false ->
     Code_error.raise
-      "External lock dir path is unsupported"
-      [ "dir", Path.External.to_dyn path ]
+      "External path is not pointing to lock dir location"
+      [ "external", Path.External.to_dyn path
+      ; "dev tool lock dir location", Path.to_dyn lock_dir_location
+      ]
   | true ->
-    let prefix = Path.External.to_string of_ in
     let as_string = Path.External.to_string path in
-    let relative =
-      String.sub
-        as_string
-        ~pos:(String.length prefix)
-        ~len:(String.length as_string - String.length prefix)
-    in
-    let exploded = String.split ~on:'/' relative in
-    (match exploded with
-     | "" :: dev_tool_name :: components ->
-       Path.Source.L.relative
-         Path.Source.root
-         ([ "_build"; ".dev-tools.locks"; dev_tool_name ] @ components)
-     | components ->
-       Code_error.raise
-         "Unexpected external path"
-         [ "dir", Path.External.to_dyn path; "components", Dyn.(list string) components ])
+    (match String.drop_prefix ~prefix:absolute as_string with
+     | None ->
+       (* we checked for descendants before, thus it has to match the prefix *)
+       assert false
+     | Some suffix ->
+       (match String.split ~on:'/' suffix with
+        | "" :: dev_tool_name :: components ->
+          Path.Source.L.relative
+            Path.Source.root
+            ([ "_build"; ".dev-tools.locks"; dev_tool_name ] @ components)
+        | components ->
+          Code_error.raise
+            "Unexpected external path"
+            [ "dir", Path.External.to_dyn path
+            ; "components", Dyn.(list string) components
+            ]))
 ;;