Relocate error messages

Author: Leonidas-from-XIV

src/dune_lang/action.mli

@@ -124,6 +124,9 @@ val encode : t Encoder.t
 val decode_dune_file : t Decoder.t
 val decode_pkg : t Decoder.t
 
+(** Transform the string in the action *)
+val map_string_with_vars : t -> f:(String_with_vars.t -> String_with_vars.t) -> t
+
 (** Raises User_error on invalid action. *)
 val validate : loc:Loc.t -> t -> unit
 

src/dune_lang/slang.ml

@@ -194,6 +194,16 @@ let loc = function
   | Form (loc, _form) -> loc
 ;;
 
+let map_loc ~f = function
+  | Nil -> Nil
+  | Literal sw ->
+    let loc = f (String_with_vars.loc sw) in
+    Literal (String_with_vars.with_loc ~loc sw)
+  | Form (loc, form) ->
+    let loc = f loc in
+    Form (loc, form)
+;;
+
 let concat ?(loc = Loc.none) ts = Form (loc, Concat ts)
 let when_ ?(loc = Loc.none) condition t = Form (loc, When (condition, t))
 

src/dune_lang/slang.mli

@@ -40,6 +40,7 @@ val decode : t Decoder.t
 val encode : t Encoder.t
 val to_dyn : t -> Dyn.t
 val loc : t -> Loc.t
+val map_loc : f:(Loc.t -> Loc.t) -> t -> t
 val concat : ?loc:Loc.t -> t list -> t
 val when_ : ?loc:Loc.t -> blang -> t -> t
 val if_ : ?loc:Loc.t -> blang -> then_:t -> else_:t -> t

src/dune_lang/string_with_vars.ml

@@ -113,6 +113,7 @@ let decode_manually f =
 
 let decode = decode_manually Pform.Env.parse
 let loc t = t.loc
+let with_loc t ~loc = { t with loc }
 
 let virt_pform ?quoted pos pform =
   let loc = Loc.of_pos pos in

src/dune_lang/string_with_vars.mli

@@ -16,6 +16,9 @@ val equal_no_loc : t -> t -> bool
 (** [loc t] returns the location of [t] — typically, in the [dune] file. *)
 val loc : t -> Loc.t
 
+(** [with_loc t ~loc] returns a new value with the new location set. *)
+val with_loc : t -> loc:Loc.t -> t
+
 val to_dyn : t Dyn.builder
 
 include Conv.S with type t := t

src/dune_pkg/lock_dir.ml

@@ -1699,6 +1699,33 @@ let merge_conditionals a b =
   { a with packages; solved_for_platforms }
 ;;
 
+let in_source_tree path =
+  match (path : Path.t) with
+  | In_source_tree s -> s
+  | In_build_dir b ->
+    let in_source = Path.drop_build_context_exn path in
+    (match Path.Source.explode in_source with
+     | "default" :: ".lock" :: components ->
+       Path.Source.L.relative Path.Source.root components
+     | _otherwise ->
+       Code_error.raise
+         "Unexpected location of lock directory in build directory"
+         [ "path", Path.Build.to_dyn b; "in_source", Path.Source.to_dyn in_source ])
+  | External e ->
+    Code_error.raise
+      "External path returned when loading a lock dir"
+      [ "path", Path.External.to_dyn e ]
+;;
+
+let loc_in_source_tree loc =
+  loc
+  |> Loc.map_pos ~f:(fun ({ pos_fname; _ } as pos) ->
+    let path = Path.of_string pos_fname in
+    let new_path = in_source_tree path in
+    let pos_fname = Path.Source.to_string new_path in
+    { pos with pos_fname })
+;;
+
 let check_if_solved_for_platform { solved_for_platforms; _ } ~platform =
   let loc, solved_for_platforms = solved_for_platforms in
   if List.is_empty solved_for_platforms
@@ -1710,6 +1737,7 @@ let check_if_solved_for_platform { solved_for_platforms; _ } ~platform =
     match Solver_env_disjunction.matches_platform solved_for_platforms ~platform with
     | true -> ()
     | false ->
+      let loc = loc_in_source_tree loc in
       User_error.raise
         ~loc
         [ Pp.text

src/dune_pkg/lock_dir.mli

@@ -181,3 +181,11 @@ val merge_conditionals : t -> t -> t
     the lockdir does not contain a solution compatible with the given platform
     then a [User_error] is raised. *)
 val packages_on_platform : t -> platform:Solver_env.t -> Pkg.t Package_name.Map.t
+
+(** Returns the path that the lock dir would be in the source. Might return
+    paths that don't exist, if the lock dir wasn't copied from there. *)
+val in_source_tree : Path.t -> Path.Source.t
+
+(** Returns a [Loc.t] which refers to the source tree lock dir path instead of
+    the build dir lock dir path. *)
+val loc_in_source_tree : Loc.t -> Loc.t

src/dune_rules/fetch_rules.ml

@@ -139,14 +139,14 @@ module Spec = struct
            ~loc:loc_url
            [ Pp.text "No checksum provided. It should be:"; Checksum.pp actual_checksum ]
        | Some (loc, _) ->
+         let loc = Dune_pkg.Lock_dir.loc_in_source_tree loc in
          User_error.raise
            ~loc
            [ Pp.text "Invalid checksum, got"; Dune_pkg.Checksum.pp actual_checksum ])
     | Error (Unavailable message) ->
-      let loc = loc_url in
       (match message with
-       | None -> User_error.raise ~loc [ Pp.text "Unknown fetch failure" ]
-       | Some msg -> User_error.raise ~loc [ User_message.pp msg ])
+       | None -> User_error.raise ~loc:loc_url [ Pp.text "Unknown fetch failure" ]
+       | Some msg -> User_error.raise ~loc:loc_url [ User_message.pp msg ])
   ;;
 end
 
@@ -220,6 +220,7 @@ let find_checksum, find_url =
 ;;
 
 let gen_rules_for_checksum_or_url (loc_url, (url : OpamUrl.t)) checksum =
+  let loc_url = Dune_pkg.Lock_dir.loc_in_source_tree loc_url in
   let checksum_or_url =
     match checksum with
     | Some (_, checksum) -> `Checksum checksum

src/dune_rules/gen_rules.ml

@@ -680,7 +680,9 @@ let raise_on_lock_dir_out_of_sync =
         with
         | `Valid -> ()
         | `Invalid ->
-          let loc = Loc.in_file (Path.relative path "lock.dune") in
+          let source_path = Dune_pkg.Lock_dir.in_source_tree path in
+          let loc_path = Path.source source_path in
+          let loc = Loc.in_file (Path.relative loc_path "lock.dune") in
           let hints = Pp.[ text "run dune pkg lock" ] in
           User_error.raise
             ~loc

src/dune_rules/pkg_rules.ml

@@ -796,6 +796,10 @@ module Action_expander = struct
     ;;
 
     let eval_slangs_located t slangs =
+      let slangs =
+        List.map slangs ~f:(fun slang ->
+          Slang.map_loc slang ~f:Dune_pkg.Lock_dir.loc_in_source_tree)
+      in
       Slang_expand.eval_multi_located slangs ~dir:t.paths.source_dir ~f:(slang_expander t)
     ;;
 
@@ -1157,6 +1161,18 @@ end = struct
     let to_dyn = Dyn.opaque
   end
 
+  let relocate action =
+    Dune_lang.Action.map_string_with_vars action ~f:(fun sw ->
+      let loc = sw |> String_with_vars.loc |> Dune_pkg.Lock_dir.loc_in_source_tree in
+      String_with_vars.with_loc sw ~loc)
+  ;;
+
+  let relocate_build b =
+    match (b : Build_command.t) with
+    | Dune -> Build_command.Dune
+    | Action a -> Build_command.Action (relocate a)
+  ;;
+
   let resolve_impl { Input.db; package = name; universe = package_universe } =
     match Package.Name.Map.find db.all name with
     | None -> Memo.return None
@@ -1238,7 +1254,9 @@ end = struct
       let id = Pkg.Id.gen () in
       let write_paths = Paths.make package_universe name ~relative:Path.Build.relative in
       let install_command = choose_for_current_platform install_command in
+      let install_command = Option.map install_command ~f:relocate in
       let build_command = choose_for_current_platform build_command in
+      let build_command = Option.map build_command ~f:relocate_build in
       let paths =
         let paths = Paths.map_path write_paths ~f:Path.build in
         match Pkg_toolchain.is_compiler_and_toolchains_enabled info.name with