Track original source location in lib_info/dune_package

CHANGES.md

@@ -93,6 +93,12 @@ unreleased
 - Generate `.merlin` files that account for normal preprocessors defined using a
   subset of the `action` language. (#1768, @rgrinberg)
 
+- Emit `(orig_src_dir <path>)` metadata in `dune-package` for dune packages
+  built with `--store-orig-source-dir` command line flag (also controlled by
+  `DUNE_STORE_ORIG_SOURCE_DIR` env variable). This is later used to generate
+  `.merlin` with `S`-directives pointed to original source locations and thus
+  allowing merlin to see those.
+
 1.6.2 (05/12/2018)
 ------------------
 

bin/common.ml

@@ -26,6 +26,7 @@ type t =
   ; ignore_promoted_rules : bool
   ; build_dir             : string
   ; no_print_directory    : bool
+  ; store_orig_src_dir    : bool
   ; (* Original arguments for the external-lib-deps hint *)
     orig_args             : string list
   ; config                : Dune.Config.t
@@ -53,6 +54,7 @@ let set_common_other c ~targets =
   Clflags.force := c.force;
   Clflags.watch := c.watch;
   Clflags.no_print_directory := c.no_print_directory;
+  Clflags.store_orig_src_dir := c.store_orig_src_dir;
   Clflags.external_lib_deps_hint :=
     List.concat
       [ ["dune"; "external-lib-deps"; "--missing"]
@@ -345,6 +347,13 @@ let term =
          & flag
          & info ["no-print-directory"] ~docs
              ~doc:"Suppress \"Entering directory\" messages")
+  and store_orig_src_dir =
+    let doc = "Store original source location in dune-package metadata" in
+    Arg.(value
+         & flag
+         & info ["store-orig-source-dir"] ~docs
+             ~env:(Arg.env_var ~doc "DUNE_STORE_ORIG_SOURCE_DIR")
+             ~doc)
   in
   let build_dir = Option.value ~default:"_build" build_dir in
   let root, to_cwd =
@@ -397,6 +406,7 @@ let term =
   ; config
   ; build_dir
   ; no_print_directory
+  ; store_orig_src_dir
   ; default_target
   ; watch
   ; stats_trace_file

bin/common.mli

@@ -15,6 +15,7 @@ type t =
   ; ignore_promoted_rules : bool
   ; build_dir             : string
   ; no_print_directory    : bool
+  ; store_orig_src_dir    : bool
   ; (* Original arguments for the external-lib-deps hint *)
     orig_args             : string list
   ; config                : Dune.Config.t

src/clflags.ml

@@ -8,3 +8,4 @@ let auto_promote = ref false
 let force = ref false
 let watch = ref false
 let no_print_directory = ref false
+let store_orig_src_dir = ref false

src/clflags.mli

@@ -29,3 +29,6 @@ val watch : bool ref
 
 (** Do not print "Entering directory" messages *)
 val no_print_directory : bool ref
+
+(** Store original source directory in dune-package metadata *)
+val store_orig_src_dir : bool ref

src/dune_package.ml

@@ -8,6 +8,7 @@ module Lib = struct
     { loc              : Loc.t
     ; name             : Lib_name.t
     ; dir              : Path.t
+    ; orig_src_dir     : Path.t option
     ; kind             : Lib_kind.t
     ; synopsis         : string option
     ; archives         : Path.t list Mode.Dict.t
@@ -29,7 +30,7 @@ module Lib = struct
   let make ~loc ~kind ~name ~synopsis ~archives ~plugins ~foreign_objects
         ~foreign_archives ~jsoo_runtime ~main_module_name ~sub_systems
         ~requires ~ppx_runtime_deps ~implements ~virtual_ ~modules ~modes
-        ~version ~dir =
+        ~version ~orig_src_dir ~dir =
     let map_path p = Path.relative dir (Path.basename p) in
     let map_list = List.map ~f:map_path in
     let map_mode = Mode.Dict.map ~f:map_list in
@@ -49,12 +50,14 @@ module Lib = struct
     ; implements
     ; version
     ; dir
+    ; orig_src_dir
     ; virtual_
     ; modules
     ; modes
     }
 
   let dir t = t.dir
+  let orig_src_dir t = t.orig_src_dir
 
   let set_subsystems t sub_systems =
     { t with sub_systems }
@@ -67,7 +70,7 @@ module Lib = struct
         { loc = _ ; kind ; synopsis ; name ; archives ; plugins
         ; foreign_objects ; foreign_archives ; jsoo_runtime ; requires
         ; ppx_runtime_deps ; sub_systems ; virtual_
-        ; implements ; main_module_name ; version = _; dir = _
+        ; implements ; main_module_name ; version = _; dir = _; orig_src_dir
         ; modules ; modes
         } =
     let open Dune_lang.Encoder in
@@ -82,6 +85,7 @@ module Lib = struct
     ; field "kind" Lib_kind.encode kind
     ; field_b "virtual" virtual_
     ; field_o "synopsis" string synopsis
+    ; field_o "orig_src_dir" path orig_src_dir
     ; mode_paths "archives" archives
     ; mode_paths "plugins" plugins
     ; paths "foreign_objects" foreign_objects
@@ -127,6 +131,7 @@ module Lib = struct
       and ppx_runtime_deps = libs "ppx_runtime_deps"
       and virtual_ = field_b "virtual"
       and sub_systems = Sub_system_info.record_parser ()
+      and orig_src_dir = field_o "orig_src_dir" path
       and modules = field_o "modules" (Lib_modules.decode
                          ~implements:(Option.is_some implements) ~dir)
       in
@@ -148,6 +153,7 @@ module Lib = struct
       ; virtual_
       ; version = None
       ; dir
+      ; orig_src_dir
       ; modules
       ; modes
       }

src/dune_package.mli

@@ -4,6 +4,7 @@ module Lib : sig
   type 'sub_system t
 
   val dir : _ t -> Path.t
+  val orig_src_dir : _ t -> Path.t option
   val requires : _ t -> (Loc.t * Lib_name.t) list
   val name : _ t -> Lib_name.t
   val version : _ t -> string option
@@ -49,6 +50,7 @@ module Lib : sig
     -> modules:Lib_modules.t option
     -> modes:Mode.Dict.Set.t
     -> version:string option
+    -> orig_src_dir:Path.t option
     -> dir:Path.t
     -> 'a t
 

src/findlib.ml

@@ -191,6 +191,7 @@ module Package = struct
     let modes : Mode.Dict.Set.t =
       Mode.Dict.map ~f:(fun x -> not (List.is_empty x)) archives in
     Dune_package.Lib.make
+      ~orig_src_dir:None
       ~loc
       ~kind:Normal
       ~name:(name t)

src/lib.ml

@@ -233,6 +233,7 @@ let modes        t = t.info.modes
 let virtual_     t = t.info.virtual_
 
 let src_dir t = t.info.src_dir
+let orig_src_dir t = Option.value ~default:t.info.src_dir t.info.orig_src_dir
 let obj_dir t = t.info.obj_dir
 
 let is_local t = Path.is_managed (Obj_dir.byte_dir t.info.obj_dir)
@@ -1274,8 +1275,21 @@ let to_dune_lib ({ name ; info ; _ } as lib) ~lib_modules ~dir =
   let add_loc = List.map ~f:(fun x -> (info.loc, x.name)) in
   let virtual_ = Option.is_some info.virtual_ in
   let lib_modules = Lib_modules.version_installed ~install_dir:dir lib_modules in
+  let orig_src_dir =
+    if !Clflags.store_orig_src_dir
+    then Some (
+      match info.orig_src_dir with
+      | Some src_dir -> src_dir
+      | None ->
+        match Path.drop_build_context info.src_dir with
+        | None -> info.src_dir
+        | Some src_dir -> Path.(of_string (to_absolute_filename src_dir))
+    )
+    else None
+  in
   Dune_package.Lib.make
     ~dir
+    ~orig_src_dir
     ~name
     ~loc:info.loc
     ~kind:info.kind

src/lib.mli

@@ -14,6 +14,7 @@ val name : t -> Lib_name.t
    have multiple source directories because of [copy_files]. *)
 (** Directory where the source files for the library are located. *)
 val src_dir : t -> Path.t
+val orig_src_dir : t -> Path.t
 
 (** Directory where the object files for the library are located. *)
 val obj_dir : t -> Obj_dir.t

src/lib_info.ml

@@ -53,6 +53,7 @@ type t =
   ; kind             : Lib_kind.t
   ; status           : Status.t
   ; src_dir          : Path.t
+  ; orig_src_dir     : Path.t option
   ; obj_dir          : Obj_dir.t
   ; version          : string option
   ; synopsis         : string option
@@ -155,6 +156,7 @@ let of_library_stanza ~dir ~has_native ~ext_lib ~ext_obj
   ; name
   ; kind     = conf.kind
   ; src_dir  = dir
+  ; orig_src_dir = None
   ; obj_dir
   ; version  = None
   ; synopsis = conf.synopsis
@@ -198,6 +200,7 @@ let of_dune_lib dp =
   ; kind = Lib.kind dp
   ; status = Installed
   ; src_dir
+  ; orig_src_dir = Lib.orig_src_dir dp
   ; obj_dir
   ; version = Lib.version dp
   ; synopsis = Lib.synopsis dp

src/lib_info.mli

@@ -33,6 +33,7 @@ type t = private
   ; kind             : Lib_kind.t
   ; status           : Status.t
   ; src_dir          : Path.t
+  ; orig_src_dir     : Path.t option
   ; obj_dir          : Obj_dir.t
   ; version          : string option
   ; synopsis         : string option

src/merlin.ml

@@ -156,7 +156,7 @@ let dot_merlin sctx ~dir ~more_src_dirs ~expander ~dir_kind
           Lib.Set.fold requires ~init:(t.source_dirs, t.objs_dirs)
             ~f:(fun (lib : Lib.t) (src_dirs, obj_dirs) ->
               ( Path.Set.add src_dirs (
-                  Lib.src_dir lib
+                  Lib.orig_src_dir lib
                   |> Path.drop_optional_build_context)
               ,
               Path.Set.add obj_dirs (Lib.public_cmi_dir lib)

test/blackbox-tests/cram.mll

@@ -8,12 +8,16 @@ type item =
   | Output  of string
   | Command of string list
   | Comment of string
+
+let cwd = Sys.getcwd ()
 }
 
 let eol = '\n' | eof
 
 let ext = '.' ['a'-'z' 'A'-'Z' '0'-'9']+
 
+let abs_path = '/' ['a'-'z' 'A'-'Z' '0'-'9' '-' '_' '/']+
+
 rule file = parse
  | eof { [] }
  | "  $ " { command [] lexbuf }
@@ -32,21 +36,37 @@ and command acc = parse
  | ([^'\n']* as str) eol
     { Command (List.rev (str :: acc)) :: file lexbuf }
 
-and postprocess tbl b = parse
+and postprocess_cwd b = parse
+  | eof { Buffer.contents b }
+  | (abs_path as path) {
+      let path =
+        match String.drop_prefix path ~prefix:cwd with
+        | None -> path
+        | Some path -> "$TESTCASE_ROOT" ^ path
+      in
+      Buffer.add_string b path; postprocess_cwd b lexbuf
+    }
+  | _ as c { Buffer.add_char b c; postprocess_cwd b lexbuf }
+
+and postprocess_ext tbl b = parse
   | eof { Buffer.contents b }
   | ([^ '/'] as c) (ext as e)
       { Buffer.add_char b c;
         begin match List.assoc tbl e with
         | Some res -> Buffer.add_string b res
         | None     -> Buffer.add_string b e
         end;
-        postprocess tbl b lexbuf
+        postprocess_ext tbl b lexbuf
       }
-  | _ as c { Buffer.add_char b c; postprocess tbl b lexbuf }
+  | _ as c { Buffer.add_char b c; postprocess_ext tbl b lexbuf }
 
 {
   module Configurator = Configurator.V1
 
+  let cwd_replace s =
+    let l = Lexing.from_string s in
+    postprocess_cwd (Buffer.create (String.length s)) l
+
   let make_ext_replace config =
     let tbl =
       let var = Configurator.ocaml_config_var_exn config in
@@ -73,7 +93,7 @@ and postprocess tbl b = parse
     List.iter tbl ~f:(fun (e, _) -> assert (e <> ""));
     fun s ->
       let l = Lexing.from_string s in
-      postprocess tbl (Buffer.create (String.length s)) l
+      postprocess_ext tbl (Buffer.create (String.length s)) l
 
   type version = int * int * int
 
@@ -159,8 +179,13 @@ and postprocess tbl b = parse
             Path.of_filename_relative_to_initial_cwd temp_file
             |> Io.lines_of_file
             |> List.iter ~f:(fun line ->
-              Printf.bprintf buf "  %s\n"
-                (ext_replace (Ansi_color.strip line)));
+              let line =
+                line
+                |> Ansi_color.strip
+                |> ext_replace
+                |> cwd_replace
+              in
+              Printf.bprintf buf "  %s\n" line);
             if n <> 0 then Printf.bprintf buf "  [%d]\n" n);
         Buffer.contents buf)
     )

test/blackbox-tests/test-cases/dune-package/run.t

@@ -28,3 +28,21 @@
     (main_module_name C)
     (modules ((name Y) (obj_name c__Y) (visibility public) (impl)))
     (wrapped true)))
+
+Build with "--store-orig-source-dir" profile
+  $ dune build --store-orig-source-dir
+  $ cat _build/install/default/lib/a/dune-package | grep -A 1 '(orig_src_dir'
+   (orig_src_dir
+    $TESTCASE_ROOT)
+  --
+   (orig_src_dir
+    $TESTCASE_ROOT)
+
+Build with "DUNE_STORE_ORIG_SOURCE_DIR=true" profile
+  $ DUNE_STORE_ORIG_SOURCE_DIR=true dune build
+  $ cat _build/install/default/lib/a/dune-package | grep -A 1 '(orig_src_dir'
+   (orig_src_dir
+    $TESTCASE_ROOT)
+  --
+   (orig_src_dir
+    $TESTCASE_ROOT)