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
|
||||
|
||||
module Named = struct
|
||||
type 'a t =
|
||||
{ named: 'a list String.Map.t
|
||||
; unnamed : 'a list
|
||||
}
|
||||
type 'a one =
|
||||
| Unnamed of 'a
|
||||
| Named of string * 'a list
|
||||
|
||||
let fold { named; unnamed } ~f ~init =
|
||||
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)
|
||||
type 'a t = 'a one list
|
||||
|
||||
let first { named; unnamed } =
|
||||
if String.Map.is_empty named then
|
||||
match unnamed with
|
||||
| [] -> Result.Error `Empty
|
||||
| x :: _ -> Ok x
|
||||
else
|
||||
Result.Error `Named_exists
|
||||
let to_list =
|
||||
List.concat_map ~f:(function
|
||||
| Unnamed x -> [x]
|
||||
| Named (_, xs) -> xs)
|
||||
|
||||
let empty =
|
||||
{ named = String.Map.empty
|
||||
; unnamed = []
|
||||
}
|
||||
let find t k =
|
||||
List.find_map t ~f:(function
|
||||
| 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 binding =
|
||||
|
@ -267,29 +269,32 @@ module Named = struct
|
|||
let name = String.sub s ~pos:1 ~len:(String.length s - 1) in
|
||||
enter (junk >>= fun () ->
|
||||
repeat elem >>| fun values ->
|
||||
Left (name, (loc, values)))
|
||||
Left (loc, name, values))
|
||||
| _ ->
|
||||
elem >>| fun elem -> Right elem
|
||||
in
|
||||
list binding >>| (fun bindings ->
|
||||
let (named, unnamed) = List.partition_map bindings ~f:(fun x -> x) in
|
||||
{ unnamed
|
||||
; named =
|
||||
(match String.Map.of_list named with
|
||||
| Ok x -> x
|
||||
| Error (name, (l1, _), (l2, _)) ->
|
||||
of_sexp_errorf l1 "Variable %s is already defined in %s"
|
||||
name (Loc.to_file_colon_line l2))
|
||||
|> String.Map.map ~f:snd
|
||||
})
|
||||
let used_names = Hashtbl.create 8 in
|
||||
List.fold_right bindings ~init:[] ~f:(fun x acc ->
|
||||
match x with
|
||||
| Right x -> Unnamed x :: acc
|
||||
| Left (loc, name, values) ->
|
||||
begin match Hashtbl.find used_names name with
|
||||
| None ->
|
||||
Hashtbl.add used_names name loc;
|
||||
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 unnamed = List.map ~f:sexp_of_a unnamed in
|
||||
let named =
|
||||
String.Map.foldi ~init:[] named ~f:(fun n d acc ->
|
||||
Sexp.unsafe_atom_of_string (":" ^ n) :: (List.map ~f:sexp_of_a d) @ acc)
|
||||
in
|
||||
Sexp.List (unnamed @ named)
|
||||
let sexp_of_t sexp_of_a bindings =
|
||||
Sexp.List (
|
||||
List.map bindings ~f:(function
|
||||
| Unnamed a -> sexp_of_a a
|
||||
| Named (name, bindings) ->
|
||||
Sexp.List (Sexp.atom (":" ^ name) :: List.map ~f:sexp_of_a bindings))
|
||||
)
|
||||
end
|
||||
|
||||
module Dep_conf = struct
|
||||
|
@ -1296,9 +1301,7 @@ module Rule = struct
|
|||
let src = name ^ ".mll" in
|
||||
let dst = name ^ ".ml" in
|
||||
{ targets = Static [dst]
|
||||
; deps = { Named.empty with
|
||||
unnamed = [File (S.virt_text __POS__ src)]
|
||||
}
|
||||
; deps = Named.singleton (Dep_conf.File (S.virt_text __POS__ src))
|
||||
; action =
|
||||
(loc,
|
||||
Chdir
|
||||
|
@ -1319,10 +1322,7 @@ module Rule = struct
|
|||
List.map modules ~f:(fun name ->
|
||||
let src = name ^ ".mly" in
|
||||
{ targets = Static [name ^ ".ml"; name ^ ".mli"]
|
||||
; deps =
|
||||
{ Named.empty with
|
||||
unnamed = [File (S.virt_text __POS__ src)]
|
||||
}
|
||||
; deps = Named.singleton (Dep_conf.File (S.virt_text __POS__ src))
|
||||
; action =
|
||||
(loc,
|
||||
Chdir
|
||||
|
|
|
@ -82,19 +82,22 @@ module Lib_deps : sig
|
|||
end
|
||||
|
||||
module Named : sig
|
||||
type 'a t =
|
||||
{ named : 'a list String.Map.t
|
||||
; unnamed : 'a list
|
||||
}
|
||||
type 'a one =
|
||||
| Unnamed of 'a
|
||||
| Named of string * 'a list
|
||||
|
||||
type 'a t = 'a one list
|
||||
|
||||
val find : 'a t -> string -> 'a list option
|
||||
|
||||
val empty : 'a t
|
||||
|
||||
val to_list : 'a t -> 'a list
|
||||
|
||||
val singleton : 'a -> 'a 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
|
||||
end
|
||||
|
||||
|
|
|
@ -527,21 +527,29 @@ module Deps = struct
|
|||
|> Build.all
|
||||
>>^ List.concat
|
||||
|
||||
let interpret_named t ~scope ~dir { Named.unnamed; named } =
|
||||
let deps l =
|
||||
List.map ~f:(dep t ~scope ~dir) l
|
||||
|> Build.all
|
||||
>>^ List.concat
|
||||
in
|
||||
let unnamed = deps unnamed 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 }
|
||||
let interpret_named t ~scope ~dir bindings =
|
||||
let unnamed x = Jbuild.Named.Unnamed x in
|
||||
List.map bindings ~f:(function
|
||||
| Jbuild.Named.Unnamed p ->
|
||||
dep t ~scope ~dir p >>^ unnamed
|
||||
| Named (s, ps) ->
|
||||
List.map ~f:(dep t ~scope ~dir) ps
|
||||
|> Build.all
|
||||
>>^ (fun deps -> Jbuild.Named.Named (s, deps)))
|
||||
|> Build.all
|
||||
>>^ List.concat_map ~f:(function
|
||||
| Jbuild.Named.Unnamed s -> List.map s ~f:unnamed
|
||||
| Named (s, ps) -> [Named (s, List.concat ps)])
|
||||
|
||||
(* 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
|
||||
|
||||
module Pkg_version = struct
|
||||
|
@ -784,13 +792,13 @@ module Action = struct
|
|||
Pform.Map.expand Pform.Map.static_vars ~syntax_version ~var
|
||||
with
|
||||
| None ->
|
||||
String.Map.find deps_written_by_user.named key
|
||||
Jbuild.Named.find deps_written_by_user key
|
||||
|> Option.map ~f:Value.L.paths
|
||||
| Some x ->
|
||||
begin match x with
|
||||
Pform.Var.Deps ->
|
||||
deps_written_by_user
|
||||
|> Jbuild.Named.fold ~init:[] ~f:List.cons
|
||||
|> Jbuild.Named.to_list
|
||||
|> Value.L.paths
|
||||
|> Option.some
|
||||
| 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.exe
|
||||
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
|
||||
B $LIB_PREFIX/lib/bytes
|
||||
B $LIB_PREFIX/lib/findlib
|
||||
|
@ -28,6 +16,18 @@
|
|||
S .
|
||||
S ../lib
|
||||
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
|
||||
|
||||
|
|
|
@ -2,22 +2,5 @@
|
|||
File "dune", line 44, characters 19-42:
|
||||
Warning: Directory dir-that-doesnt-exist doesn't exist.
|
||||
diff alias runtest
|
||||
diff alias runtest (exit 1)
|
||||
(cd _build/default && /usr/bin/diff -u result expected)
|
||||
--- 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]
|
||||
diff alias runtest
|
||||
diff alias runtest
|
||||
|
|
Loading…
Reference in New Issue