Merge branch 'master' into add-classical-ppx-test
This commit is contained in:
commit
b057c40668
|
@ -1137,31 +1137,19 @@ module Trace = struct
|
||||||
|
|
||||||
let file = Path.relative Path.build_dir ".db"
|
let file = Path.relative Path.build_dir ".db"
|
||||||
|
|
||||||
let dump (trace : t) =
|
module P = Utils.Persistent(struct
|
||||||
let sexp =
|
type nonrec t = t
|
||||||
Sexp.List (
|
let name = "INCREMENTAL-DB"
|
||||||
Hashtbl.foldi trace ~init:Path.Map.empty ~f:(fun key data acc ->
|
let version = 1
|
||||||
Path.Map.add acc key data)
|
end)
|
||||||
|> Path.Map.to_list
|
|
||||||
|> List.map ~f:(fun (path, hash) ->
|
let dump t =
|
||||||
Sexp.List [ Path.sexp_of_t path;
|
if Path.build_dir_exists () then P.dump file t
|
||||||
Atom (Sexp.Atom.of_digest hash) ]))
|
|
||||||
in
|
|
||||||
if Path.build_dir_exists () then
|
|
||||||
Io.write_file file (Sexp.to_string sexp)
|
|
||||||
|
|
||||||
let load () =
|
let load () =
|
||||||
let trace = Hashtbl.create 1024 in
|
match P.load file with
|
||||||
if Path.exists file then begin
|
| Some t -> t
|
||||||
let sexp = Io.Sexp.load file ~mode:Single in
|
| None -> Hashtbl.create 1024
|
||||||
let bindings =
|
|
||||||
let open Sexp.Of_sexp in
|
|
||||||
list (pair Path.t (fun s -> Digest.from_hex (string s))) sexp
|
|
||||||
in
|
|
||||||
List.iter bindings ~f:(fun (path, hash) ->
|
|
||||||
Hashtbl.add trace path hash);
|
|
||||||
end;
|
|
||||||
trace
|
|
||||||
end
|
end
|
||||||
|
|
||||||
let all_targets t =
|
let all_targets t =
|
||||||
|
|
|
@ -199,6 +199,11 @@ let load ?(extra_ignored_subtrees=Path.Set.empty) path =
|
||||||
Left fn)
|
Left fn)
|
||||||
in
|
in
|
||||||
let files = String.Set.of_list files in
|
let files = String.Set.of_list files in
|
||||||
|
let sub_dirs =
|
||||||
|
List.sort
|
||||||
|
~compare:(fun (a, _, _) (b, _, _) -> String.compare a b)
|
||||||
|
sub_dirs
|
||||||
|
in
|
||||||
let project =
|
let project =
|
||||||
match Dune_project.load ~dir:path ~files with
|
match Dune_project.load ~dir:path ~files with
|
||||||
| Some _ as x -> x
|
| Some _ as x -> x
|
||||||
|
|
|
@ -127,19 +127,19 @@ let dot_merlin sctx ~dir ~scope ({ requires; flags; _ } as t) =
|
||||||
flags
|
flags
|
||||||
>>^ (fun flags ->
|
>>^ (fun flags ->
|
||||||
let (src_dirs, obj_dirs) =
|
let (src_dirs, obj_dirs) =
|
||||||
Lib.Set.fold requires ~init:(Path.Set.empty, Path.Set.empty)
|
Lib.Set.fold requires ~init:(t.source_dirs, t.objs_dirs)
|
||||||
~f:(fun (lib : Lib.t) (src_dirs, build_dirs) ->
|
~f:(fun (lib : Lib.t) (src_dirs, obj_dirs) ->
|
||||||
( Path.Set.add src_dirs (Lib.src_dir lib)
|
( Path.Set.add src_dirs (
|
||||||
, Path.Set.add build_dirs (
|
Lib.src_dir lib
|
||||||
Lib.obj_dir lib
|
|> Path.drop_optional_build_context)
|
||||||
|> Path.drop_optional_build_context)))
|
, Path.Set.add obj_dirs (Lib.obj_dir lib)))
|
||||||
in
|
in
|
||||||
Dot_file.to_string
|
Dot_file.to_string
|
||||||
~remaindir
|
~remaindir
|
||||||
~ppx:(ppx_flags sctx ~dir ~scope ~src_dir:remaindir t)
|
~ppx:(ppx_flags sctx ~dir ~scope ~src_dir:remaindir t)
|
||||||
~flags
|
~flags
|
||||||
~src_dirs:(Path.Set.union src_dirs t.source_dirs)
|
~src_dirs
|
||||||
~obj_dirs:(Path.Set.union obj_dirs t.objs_dirs))
|
~obj_dirs)
|
||||||
>>>
|
>>>
|
||||||
Build.write_file_dyn merlin_file)
|
Build.write_file_dyn merlin_file)
|
||||||
|
|
||||||
|
|
96
src/utils.ml
96
src/utils.ml
|
@ -146,19 +146,55 @@ let install_file ~(package : Package.Name.t) ~findlib_toolchain =
|
||||||
| None -> package ^ ".install"
|
| None -> package ^ ".install"
|
||||||
| Some x -> sprintf "%s-%s.install" package x
|
| Some x -> sprintf "%s-%s.install" package x
|
||||||
|
|
||||||
|
module type Persistent_desc = sig
|
||||||
|
type t
|
||||||
|
val name : string
|
||||||
|
val version : int
|
||||||
|
end
|
||||||
|
|
||||||
|
module Persistent(D : Persistent_desc) = struct
|
||||||
|
let magic = sprintf "DUNE-%sv%d:" D.name D.version
|
||||||
|
|
||||||
|
let dump file (v : D.t) =
|
||||||
|
Io.with_file_out file ~f:(fun oc ->
|
||||||
|
output_string oc magic;
|
||||||
|
Marshal.to_channel oc v [])
|
||||||
|
|
||||||
|
let load file =
|
||||||
|
if Path.exists file then
|
||||||
|
Io.with_file_in file ~f:(fun ic ->
|
||||||
|
match really_input_string ic (String.length magic) with
|
||||||
|
| exception End_of_file -> None
|
||||||
|
| s ->
|
||||||
|
if s = magic then
|
||||||
|
Some (Marshal.from_channel ic : D.t)
|
||||||
|
else
|
||||||
|
None)
|
||||||
|
else
|
||||||
|
None
|
||||||
|
end
|
||||||
|
|
||||||
module Cached_digest = struct
|
module Cached_digest = struct
|
||||||
type file =
|
type file =
|
||||||
{ mutable digest : Digest.t
|
{ mutable digest : Digest.t
|
||||||
; mutable timestamp : float
|
; mutable timestamp : float
|
||||||
; mutable timestamp_checked : bool
|
; mutable timestamp_checked : int
|
||||||
}
|
}
|
||||||
|
|
||||||
let cache = Hashtbl.create 1024
|
type t =
|
||||||
|
{ mutable checked_key : int
|
||||||
|
; mutable table : (Path.t, file) Hashtbl.t
|
||||||
|
}
|
||||||
|
|
||||||
|
let cache =
|
||||||
|
{ checked_key = 0
|
||||||
|
; table = Hashtbl.create 1024
|
||||||
|
}
|
||||||
|
|
||||||
let file fn =
|
let file fn =
|
||||||
match Hashtbl.find cache fn with
|
match Hashtbl.find cache.table fn with
|
||||||
| Some x ->
|
| Some x ->
|
||||||
if x.timestamp_checked then
|
if x.timestamp_checked = cache.checked_key then
|
||||||
x.digest
|
x.digest
|
||||||
else begin
|
else begin
|
||||||
let mtime = (Unix.stat (Path.to_string fn)).st_mtime in
|
let mtime = (Unix.stat (Path.to_string fn)).st_mtime in
|
||||||
|
@ -167,55 +203,35 @@ module Cached_digest = struct
|
||||||
x.digest <- digest;
|
x.digest <- digest;
|
||||||
x.timestamp <- mtime;
|
x.timestamp <- mtime;
|
||||||
end;
|
end;
|
||||||
x.timestamp_checked <- true;
|
x.timestamp_checked <- cache.checked_key;
|
||||||
x.digest
|
x.digest
|
||||||
end
|
end
|
||||||
| None ->
|
| None ->
|
||||||
let digest = Digest.file (Path.to_string fn) in
|
let digest = Digest.file (Path.to_string fn) in
|
||||||
Hashtbl.add cache fn
|
Hashtbl.add cache.table fn
|
||||||
{ digest
|
{ digest
|
||||||
; timestamp = (Unix.stat (Path.to_string fn)).st_mtime
|
; timestamp = (Unix.stat (Path.to_string fn)).st_mtime
|
||||||
; timestamp_checked = true
|
; timestamp_checked = cache.checked_key
|
||||||
};
|
};
|
||||||
digest
|
digest
|
||||||
|
|
||||||
let remove fn = Hashtbl.remove cache fn
|
let remove fn = Hashtbl.remove cache.table fn
|
||||||
|
|
||||||
let db_file = Path.relative Path.build_dir ".digest-db"
|
let db_file = Path.relative Path.build_dir ".digest-db"
|
||||||
|
|
||||||
|
module P = Persistent(struct
|
||||||
|
type nonrec t = t
|
||||||
|
let name = "DIGEST-DB"
|
||||||
|
let version = 1
|
||||||
|
end)
|
||||||
|
|
||||||
let dump () =
|
let dump () =
|
||||||
let sexp =
|
if Path.build_dir_exists () then P.dump db_file cache
|
||||||
Sexp.List (
|
|
||||||
Hashtbl.foldi cache ~init:Path.Map.empty ~f:(fun key data acc ->
|
|
||||||
Path.Map.add acc key data)
|
|
||||||
|> Path.Map.to_list
|
|
||||||
|> List.map ~f:(fun (path, file) ->
|
|
||||||
Sexp.List [ Quoted_string (Path.to_string path)
|
|
||||||
; Atom (Sexp.Atom.of_digest file.digest)
|
|
||||||
; Atom (Sexp.Atom.of_int64
|
|
||||||
(Int64.bits_of_float file.timestamp))
|
|
||||||
]))
|
|
||||||
in
|
|
||||||
if Path.build_dir_exists () then
|
|
||||||
Io.write_file db_file (Sexp.to_string sexp)
|
|
||||||
|
|
||||||
let load () =
|
let load () =
|
||||||
if Path.exists db_file then begin
|
match P.load db_file with
|
||||||
let sexp = Io.Sexp.load db_file ~mode:Single in
|
| None -> ()
|
||||||
let bindings =
|
| Some c ->
|
||||||
let open Sexp.Of_sexp in
|
cache.checked_key <- c.checked_key + 1;
|
||||||
list
|
cache.table <- c.table
|
||||||
(triple
|
|
||||||
Path.t
|
|
||||||
(fun s -> Digest.from_hex (string s))
|
|
||||||
(fun s -> Int64.float_of_bits (Int64.of_string (string s)))
|
|
||||||
) sexp
|
|
||||||
in
|
|
||||||
List.iter bindings ~f:(fun (path, digest, timestamp) ->
|
|
||||||
Hashtbl.add cache path
|
|
||||||
{ digest
|
|
||||||
; timestamp
|
|
||||||
; timestamp_checked = false
|
|
||||||
});
|
|
||||||
end
|
|
||||||
end
|
end
|
||||||
|
|
|
@ -55,6 +55,18 @@ val install_file
|
||||||
-> findlib_toolchain:string option
|
-> findlib_toolchain:string option
|
||||||
-> string
|
-> string
|
||||||
|
|
||||||
|
module type Persistent_desc = sig
|
||||||
|
type t
|
||||||
|
val name : string
|
||||||
|
val version : int
|
||||||
|
end
|
||||||
|
|
||||||
|
(** Persistent value stored on disk *)
|
||||||
|
module Persistent(D : Persistent_desc) : sig
|
||||||
|
val dump : Path.t -> D.t -> unit
|
||||||
|
val load : Path.t -> D.t option
|
||||||
|
end
|
||||||
|
|
||||||
(** Digest files with caching *)
|
(** Digest files with caching *)
|
||||||
module Cached_digest : sig
|
module Cached_digest : sig
|
||||||
(** Digest the contents of the following file *)
|
(** Digest the contents of the following file *)
|
||||||
|
|
|
@ -9,12 +9,12 @@
|
||||||
B $LIB_PREFIX/lib/findlib
|
B $LIB_PREFIX/lib/findlib
|
||||||
B $LIB_PREFIX/lib/ocaml
|
B $LIB_PREFIX/lib/ocaml
|
||||||
B ../_build/default/exe/.x.eobjs
|
B ../_build/default/exe/.x.eobjs
|
||||||
B ../lib/.foo.objs
|
B ../_build/default/lib/.foo.objs
|
||||||
S $LIB_PREFIX/lib/bytes
|
S $LIB_PREFIX/lib/bytes
|
||||||
S $LIB_PREFIX/lib/findlib
|
S $LIB_PREFIX/lib/findlib
|
||||||
S $LIB_PREFIX/lib/ocaml
|
S $LIB_PREFIX/lib/ocaml
|
||||||
S ../_build/default/lib
|
|
||||||
S .
|
S .
|
||||||
|
S ../lib
|
||||||
FLG -w -40
|
FLG -w -40
|
||||||
# Processing lib/.merlin
|
# Processing lib/.merlin
|
||||||
B $LIB_PREFIX/lib/bytes
|
B $LIB_PREFIX/lib/bytes
|
||||||
|
|
Loading…
Reference in New Issue