Change binding representation to use a list
This preserves the order of things Signed-off-by: Rudi Grinberg <rudi.grinberg@gmail.com>
This commit is contained in:
parent
0b1abc68bd
commit
bfc1b9fd25
|
@ -233,31 +233,33 @@ module Pps_and_flags = struct
|
||||||
end
|
end
|
||||||
|
|
||||||
module Named = struct
|
module Named = struct
|
||||||
type 'a t =
|
type 'a one =
|
||||||
{ named: 'a list String.Map.t
|
| Unnamed of 'a
|
||||||
; unnamed : 'a list
|
| Named of string * 'a list
|
||||||
}
|
|
||||||
|
|
||||||
let fold { named; unnamed } ~f ~init =
|
type 'a t = 'a one list
|
||||||
let flipped x acc = f acc x in
|
|
||||||
String.Map.fold named
|
|
||||||
~f:(fun x init -> List.fold_left ~f:flipped ~init x)
|
|
||||||
~init:(List.fold_left ~f:flipped ~init unnamed)
|
|
||||||
|
|
||||||
let first { named; unnamed } =
|
let to_list =
|
||||||
if String.Map.is_empty named then
|
List.concat_map ~f:(function
|
||||||
match unnamed with
|
| Unnamed x -> [x]
|
||||||
| [] -> Result.Error `Empty
|
| Named (_, xs) -> xs)
|
||||||
| x :: _ -> Ok x
|
|
||||||
else
|
|
||||||
Result.Error `Named_exists
|
|
||||||
|
|
||||||
let empty =
|
let find t k =
|
||||||
{ named = String.Map.empty
|
List.find_map t ~f:(function
|
||||||
; unnamed = []
|
| Unnamed _ -> None
|
||||||
}
|
| Named (k', x) -> Option.some_if (k = k') x)
|
||||||
|
|
||||||
let singleton x = { empty with unnamed = [x] }
|
let first t =
|
||||||
|
let rec loop acc = function
|
||||||
|
| [] -> acc
|
||||||
|
| Unnamed x :: xs -> loop (Result.Ok x) xs
|
||||||
|
| Named (_, _) :: _ -> Result.Error `Named_exists
|
||||||
|
in
|
||||||
|
loop (Result.Error `Empty) t
|
||||||
|
|
||||||
|
let empty = []
|
||||||
|
|
||||||
|
let singleton x = [Unnamed x]
|
||||||
|
|
||||||
let t elem =
|
let t elem =
|
||||||
let binding =
|
let binding =
|
||||||
|
@ -267,29 +269,32 @@ module Named = struct
|
||||||
let name = String.sub s ~pos:1 ~len:(String.length s - 1) in
|
let name = String.sub s ~pos:1 ~len:(String.length s - 1) in
|
||||||
enter (junk >>= fun () ->
|
enter (junk >>= fun () ->
|
||||||
repeat elem >>| fun values ->
|
repeat elem >>| fun values ->
|
||||||
Left (name, (loc, values)))
|
Left (loc, name, values))
|
||||||
| _ ->
|
| _ ->
|
||||||
elem >>| fun elem -> Right elem
|
elem >>| fun elem -> Right elem
|
||||||
in
|
in
|
||||||
list binding >>| (fun bindings ->
|
list binding >>| (fun bindings ->
|
||||||
let (named, unnamed) = List.partition_map bindings ~f:(fun x -> x) in
|
let used_names = Hashtbl.create 8 in
|
||||||
{ unnamed
|
List.fold_right bindings ~init:[] ~f:(fun x acc ->
|
||||||
; named =
|
match x with
|
||||||
(match String.Map.of_list named with
|
| Right x -> Unnamed x :: acc
|
||||||
| Ok x -> x
|
| Left (loc, name, values) ->
|
||||||
| Error (name, (l1, _), (l2, _)) ->
|
begin match Hashtbl.find used_names name with
|
||||||
of_sexp_errorf l1 "Variable %s is already defined in %s"
|
| None ->
|
||||||
name (Loc.to_file_colon_line l2))
|
Hashtbl.add used_names name loc;
|
||||||
|> String.Map.map ~f:snd
|
Named (name, values) :: acc
|
||||||
})
|
| Some loc_old ->
|
||||||
|
of_sexp_errorf loc "Variable %s is already defined in %s"
|
||||||
|
name (Loc.to_file_colon_line loc_old)
|
||||||
|
end))
|
||||||
|
|
||||||
let sexp_of_t sexp_of_a { unnamed; named } =
|
let sexp_of_t sexp_of_a bindings =
|
||||||
let unnamed = List.map ~f:sexp_of_a unnamed in
|
Sexp.List (
|
||||||
let named =
|
List.map bindings ~f:(function
|
||||||
String.Map.foldi ~init:[] named ~f:(fun n d acc ->
|
| Unnamed a -> sexp_of_a a
|
||||||
Sexp.unsafe_atom_of_string (":" ^ n) :: (List.map ~f:sexp_of_a d) @ acc)
|
| Named (name, bindings) ->
|
||||||
in
|
Sexp.List (Sexp.atom (":" ^ name) :: List.map ~f:sexp_of_a bindings))
|
||||||
Sexp.List (unnamed @ named)
|
)
|
||||||
end
|
end
|
||||||
|
|
||||||
module Dep_conf = struct
|
module Dep_conf = struct
|
||||||
|
@ -1296,9 +1301,7 @@ module Rule = struct
|
||||||
let src = name ^ ".mll" in
|
let src = name ^ ".mll" in
|
||||||
let dst = name ^ ".ml" in
|
let dst = name ^ ".ml" in
|
||||||
{ targets = Static [dst]
|
{ targets = Static [dst]
|
||||||
; deps = { Named.empty with
|
; deps = Named.singleton (Dep_conf.File (S.virt_text __POS__ src))
|
||||||
unnamed = [File (S.virt_text __POS__ src)]
|
|
||||||
}
|
|
||||||
; action =
|
; action =
|
||||||
(loc,
|
(loc,
|
||||||
Chdir
|
Chdir
|
||||||
|
@ -1319,10 +1322,7 @@ module Rule = struct
|
||||||
List.map modules ~f:(fun name ->
|
List.map modules ~f:(fun name ->
|
||||||
let src = name ^ ".mly" in
|
let src = name ^ ".mly" in
|
||||||
{ targets = Static [name ^ ".ml"; name ^ ".mli"]
|
{ targets = Static [name ^ ".ml"; name ^ ".mli"]
|
||||||
; deps =
|
; deps = Named.singleton (Dep_conf.File (S.virt_text __POS__ src))
|
||||||
{ Named.empty with
|
|
||||||
unnamed = [File (S.virt_text __POS__ src)]
|
|
||||||
}
|
|
||||||
; action =
|
; action =
|
||||||
(loc,
|
(loc,
|
||||||
Chdir
|
Chdir
|
||||||
|
|
|
@ -82,19 +82,22 @@ module Lib_deps : sig
|
||||||
end
|
end
|
||||||
|
|
||||||
module Named : sig
|
module Named : sig
|
||||||
type 'a t =
|
type 'a one =
|
||||||
{ named : 'a list String.Map.t
|
| Unnamed of 'a
|
||||||
; unnamed : 'a list
|
| Named of string * 'a list
|
||||||
}
|
|
||||||
|
type 'a t = 'a one list
|
||||||
|
|
||||||
|
val find : 'a t -> string -> 'a list option
|
||||||
|
|
||||||
val empty : 'a t
|
val empty : 'a t
|
||||||
|
|
||||||
|
val to_list : 'a t -> 'a list
|
||||||
|
|
||||||
val singleton : 'a -> 'a t
|
val singleton : 'a -> 'a t
|
||||||
|
|
||||||
val first : 'a t -> ('a, [`Empty | `Named_exists]) Result.t
|
val first : 'a t -> ('a, [`Empty | `Named_exists]) Result.t
|
||||||
|
|
||||||
val fold : 'a t -> f:('a -> 'init -> 'init) -> init:'init -> 'init
|
|
||||||
|
|
||||||
val sexp_of_t : ('a -> Usexp.t) -> 'a t -> Usexp.t
|
val sexp_of_t : ('a -> Usexp.t) -> 'a t -> Usexp.t
|
||||||
end
|
end
|
||||||
|
|
||||||
|
|
|
@ -527,21 +527,29 @@ module Deps = struct
|
||||||
|> Build.all
|
|> Build.all
|
||||||
>>^ List.concat
|
>>^ List.concat
|
||||||
|
|
||||||
let interpret_named t ~scope ~dir { Named.unnamed; named } =
|
let interpret_named t ~scope ~dir bindings =
|
||||||
let deps l =
|
let unnamed x = Jbuild.Named.Unnamed x in
|
||||||
List.map ~f:(dep t ~scope ~dir) l
|
List.map bindings ~f:(function
|
||||||
|> Build.all
|
| Jbuild.Named.Unnamed p ->
|
||||||
>>^ List.concat
|
dep t ~scope ~dir p >>^ unnamed
|
||||||
in
|
| Named (s, ps) ->
|
||||||
let unnamed = deps unnamed in
|
List.map ~f:(dep t ~scope ~dir) ps
|
||||||
let named =
|
|> Build.all
|
||||||
String.Map.to_list named
|
>>^ (fun deps -> Jbuild.Named.Named (s, deps)))
|
||||||
|> List.map ~f:(fun (k, d) -> deps d >>^ fun d -> (k, d))
|
|> Build.all
|
||||||
|> Build.all
|
>>^ List.concat_map ~f:(function
|
||||||
>>^ String.Map.of_list_exn
|
| Jbuild.Named.Unnamed s -> List.map s ~f:unnamed
|
||||||
in
|
| Named (s, ps) -> [Named (s, List.concat ps)])
|
||||||
unnamed &&& named >>^ fun (unnamed, named) ->
|
|
||||||
{ Named.unnamed; named }
|
(* let unnamed = deps (Jbuild.Named.unnamed bindings) in
|
||||||
|
* let named =
|
||||||
|
* String.Map.to_list named
|
||||||
|
* |> List.map ~f:(fun (k, d) -> deps d >>^ fun d -> (k, d))
|
||||||
|
* |> Build.all
|
||||||
|
* >>^ String.Map.of_list_exn
|
||||||
|
* in
|
||||||
|
* unnamed &&& named >>^ fun (unnamed, named) ->
|
||||||
|
* { Named.unnamed; named } *)
|
||||||
end
|
end
|
||||||
|
|
||||||
module Pkg_version = struct
|
module Pkg_version = struct
|
||||||
|
@ -784,13 +792,13 @@ module Action = struct
|
||||||
Pform.Map.expand Pform.Map.static_vars ~syntax_version ~var
|
Pform.Map.expand Pform.Map.static_vars ~syntax_version ~var
|
||||||
with
|
with
|
||||||
| None ->
|
| None ->
|
||||||
String.Map.find deps_written_by_user.named key
|
Jbuild.Named.find deps_written_by_user key
|
||||||
|> Option.map ~f:Value.L.paths
|
|> Option.map ~f:Value.L.paths
|
||||||
| Some x ->
|
| Some x ->
|
||||||
begin match x with
|
begin match x with
|
||||||
Pform.Var.Deps ->
|
Pform.Var.Deps ->
|
||||||
deps_written_by_user
|
deps_written_by_user
|
||||||
|> Jbuild.Named.fold ~init:[] ~f:List.cons
|
|> Jbuild.Named.to_list
|
||||||
|> Value.L.paths
|
|> Value.L.paths
|
||||||
|> Option.some
|
|> Option.some
|
||||||
| First_dep ->
|
| First_dep ->
|
||||||
|
|
|
@ -4,18 +4,6 @@
|
||||||
ocamlopt sanitize-dot-merlin/.sanitize_dot_merlin.eobjs/sanitize_dot_merlin.{cmx,o}
|
ocamlopt sanitize-dot-merlin/.sanitize_dot_merlin.eobjs/sanitize_dot_merlin.{cmx,o}
|
||||||
ocamlopt sanitize-dot-merlin/sanitize_dot_merlin.exe
|
ocamlopt sanitize-dot-merlin/sanitize_dot_merlin.exe
|
||||||
sanitize_dot_merlin alias print-merlins
|
sanitize_dot_merlin alias print-merlins
|
||||||
# Processing lib/.merlin
|
|
||||||
B $LIB_PREFIX/lib/bytes
|
|
||||||
B $LIB_PREFIX/lib/findlib
|
|
||||||
B $LIB_PREFIX/lib/ocaml
|
|
||||||
B ../_build/default/lib/.bar.objs
|
|
||||||
B ../_build/default/lib/.foo.objs
|
|
||||||
S $LIB_PREFIX/lib/bytes
|
|
||||||
S $LIB_PREFIX/lib/findlib
|
|
||||||
S $LIB_PREFIX/lib/ocaml
|
|
||||||
S .
|
|
||||||
FLG -ppx '$PPX/fooppx@./ppx.exe --as-ppx --cookie '\''library-name="foo"'\'''
|
|
||||||
FLG -open Foo -w -40 -open Bar -w -40
|
|
||||||
# Processing exe/.merlin
|
# Processing exe/.merlin
|
||||||
B $LIB_PREFIX/lib/bytes
|
B $LIB_PREFIX/lib/bytes
|
||||||
B $LIB_PREFIX/lib/findlib
|
B $LIB_PREFIX/lib/findlib
|
||||||
|
@ -28,6 +16,18 @@
|
||||||
S .
|
S .
|
||||||
S ../lib
|
S ../lib
|
||||||
FLG -w -40
|
FLG -w -40
|
||||||
|
# Processing lib/.merlin
|
||||||
|
B $LIB_PREFIX/lib/bytes
|
||||||
|
B $LIB_PREFIX/lib/findlib
|
||||||
|
B $LIB_PREFIX/lib/ocaml
|
||||||
|
B ../_build/default/lib/.bar.objs
|
||||||
|
B ../_build/default/lib/.foo.objs
|
||||||
|
S $LIB_PREFIX/lib/bytes
|
||||||
|
S $LIB_PREFIX/lib/findlib
|
||||||
|
S $LIB_PREFIX/lib/ocaml
|
||||||
|
S .
|
||||||
|
FLG -ppx '$PPX/fooppx@./ppx.exe --as-ppx --cookie '\''library-name="foo"'\'''
|
||||||
|
FLG -open Foo -w -40 -open Bar -w -40
|
||||||
|
|
||||||
Make sure a ppx directive is generated
|
Make sure a ppx directive is generated
|
||||||
|
|
||||||
|
|
|
@ -2,22 +2,5 @@
|
||||||
File "dune", line 44, characters 19-42:
|
File "dune", line 44, characters 19-42:
|
||||||
Warning: Directory dir-that-doesnt-exist doesn't exist.
|
Warning: Directory dir-that-doesnt-exist doesn't exist.
|
||||||
diff alias runtest
|
diff alias runtest
|
||||||
diff alias runtest (exit 1)
|
diff alias runtest
|
||||||
(cd _build/default && /usr/bin/diff -u result expected)
|
diff alias runtest
|
||||||
--- result 2018-07-09 16:03:03.123914026 +0100
|
|
||||||
+++ expected 2018-07-09 16:03:03.124914029 +0100
|
|
||||||
@@ -1 +1 @@
|
|
||||||
-c.txt b.txt a.txt dune
|
|
||||||
\ No newline at end of file
|
|
||||||
+dune a.txt b.txt c.txt
|
|
||||||
\ No newline at end of file
|
|
||||||
diff alias runtest (exit 1)
|
|
||||||
(cd _build/default && /usr/bin/diff -u result2 expected2)
|
|
||||||
--- result2 2018-07-09 16:03:03.124914029 +0100
|
|
||||||
+++ expected2 2018-07-09 16:03:03.124914029 +0100
|
|
||||||
@@ -1 +1 @@
|
|
||||||
-sub-tree/dir/b sub-tree/a
|
|
||||||
\ No newline at end of file
|
|
||||||
+sub-tree/a sub-tree/dir/b
|
|
||||||
\ No newline at end of file
|
|
||||||
[1]
|
|
||||||
|
|
Loading…
Reference in New Issue