Parse bindings in the new syntax
Signed-off-by: Rudi Grinberg <rudi.grinberg@gmail.com>
This commit is contained in:
parent
2b7a7fcdff
commit
8fa41edcff
|
@ -262,21 +262,16 @@ module Named = struct
|
|||
let t elem =
|
||||
let binding =
|
||||
peek_exn >>= function
|
||||
| Atom (loc, A s) when String.length s > 1 && s.[0] = ':' ->
|
||||
begin
|
||||
string >>= fun name ->
|
||||
peek >>= function
|
||||
| None -> of_sexp_errorf loc "Naked binding %s" s
|
||||
| Some _ ->
|
||||
elem >>| fun elem ->
|
||||
Left (name, (loc, elem))
|
||||
end
|
||||
| List (_, Atom (loc, A s) :: _) when
|
||||
String.length s > 1 && s.[0] = ':' ->
|
||||
binding elem >>| fun (name, values) ->
|
||||
Left (name, (loc, values))
|
||||
| _ ->
|
||||
elem >>| fun elem -> Right elem
|
||||
in
|
||||
list binding >>| (fun bindings ->
|
||||
let (named, unnamed) = List.partition_map bindings ~f:(fun x -> x) in
|
||||
{ unnamed = List.flatten unnamed
|
||||
{ unnamed
|
||||
; named =
|
||||
(match String.Map.of_list named with
|
||||
| Ok x -> x
|
||||
|
@ -331,15 +326,6 @@ module Dep_conf = struct
|
|||
let t =
|
||||
make_dep_parser ~single:(fun x -> x) ~many:(sum dep_cons)
|
||||
|
||||
let bindings =
|
||||
let dep =
|
||||
make_dep_parser ~single:List.singleton ~many:(
|
||||
("list", repeat t)
|
||||
:: List.map dep_cons ~f:(fun (n, d) -> (n, d >>| List.singleton))
|
||||
|> sum)
|
||||
in
|
||||
Named.t dep
|
||||
|
||||
open Sexp
|
||||
let sexp_of_t = function
|
||||
| File t ->
|
||||
|
@ -1202,7 +1188,7 @@ module Rule = struct
|
|||
>>= fun action ->
|
||||
field "targets" (list file_in_current_dir)
|
||||
>>= fun targets ->
|
||||
field "deps" Dep_conf.bindings ~default:Named.empty
|
||||
field "deps" (Named.t Dep_conf.t) ~default:Named.empty
|
||||
>>= fun deps ->
|
||||
field "locks" (list String_with_vars.t) ~default:[] >>= fun locks ->
|
||||
map_validate
|
||||
|
@ -1421,7 +1407,7 @@ module Alias_conf = struct
|
|||
field_o "package" Pkg.t >>= fun package ->
|
||||
field_o "action" (located Action.Unexpanded.t) >>= fun action ->
|
||||
field "locks" (list String_with_vars.t) ~default:[] >>= fun locks ->
|
||||
field "deps" Dep_conf.bindings ~default:Named.empty
|
||||
field "deps" (Named.t Dep_conf.t) ~default:Named.empty
|
||||
>>= fun deps ->
|
||||
return
|
||||
{ name
|
||||
|
@ -1445,7 +1431,7 @@ module Tests = struct
|
|||
(Buildable.t >>= fun buildable ->
|
||||
field_oslu "link_flags" >>= fun link_flags ->
|
||||
names >>= fun names ->
|
||||
field "deps" Dep_conf.bindings ~default:Named.empty >>= fun deps ->
|
||||
field "deps" (Named.t Dep_conf.t) ~default:Named.empty >>= fun deps ->
|
||||
field_o "package" Pkg.t >>= fun package ->
|
||||
field "locks" (list String_with_vars.t) ~default:[] >>= fun locks ->
|
||||
field "modes" Executables.Link_mode.Set.t
|
||||
|
|
|
@ -380,6 +380,26 @@ module Of_sexp = struct
|
|||
}
|
||||
"Unknown constructor %s" name
|
||||
|
||||
let binding t =
|
||||
let t name = repeat t >>| fun t -> (name, t) in
|
||||
next_with_user_context (fun uc sexp ->
|
||||
match sexp with
|
||||
| Atom (loc, A s) ->
|
||||
let ctx = Values (loc, Some s, uc) in
|
||||
result ctx (t s ctx [])
|
||||
| Template { loc; _ }
|
||||
| Quoted_string (loc, _) ->
|
||||
of_sexp_error loc "Atom expected"
|
||||
| List (loc, []) ->
|
||||
of_sexp_error loc "Non-empty list expected"
|
||||
| List (loc, name :: args) ->
|
||||
match name with
|
||||
| Quoted_string (loc, _) | List (loc, _) | Template { loc; _ } ->
|
||||
of_sexp_error loc "Atom expected"
|
||||
| Atom (s_loc, A s) ->
|
||||
let ctx loc = Values (loc, Some s, uc) in
|
||||
result (ctx s_loc) (t s (ctx loc) args))
|
||||
|
||||
let sum cstrs =
|
||||
next_with_user_context (fun uc sexp ->
|
||||
match sexp with
|
||||
|
|
|
@ -201,6 +201,8 @@ module Of_sexp : sig
|
|||
list parser. *)
|
||||
val sum : (string * 'a t) list -> 'a t
|
||||
|
||||
val binding : 'a t -> (string * ('a list)) t
|
||||
|
||||
(** Check the result of a list parser, and raise a properly located
|
||||
error in case of failure. *)
|
||||
val map_validate
|
||||
|
|
|
@ -1,5 +1,5 @@
|
|||
|
||||
(rule
|
||||
(deps :foo (list a b) :baz foo (list (alias test)) (list a b c))
|
||||
(deps (:foo a b) (:baz foo (alias test)) a b c)
|
||||
(targets bar)
|
||||
(action (with-stdout-to bar (echo "foo"))))
|
||||
|
|
|
@ -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 exe/.merlin
|
||||
B $LIB_PREFIX/lib/bytes
|
||||
B $LIB_PREFIX/lib/findlib
|
||||
B $LIB_PREFIX/lib/ocaml
|
||||
B ../_build/default/exe/.x.eobjs
|
||||
B ../_build/default/lib/.foo.objs
|
||||
S $LIB_PREFIX/lib/bytes
|
||||
S $LIB_PREFIX/lib/findlib
|
||||
S $LIB_PREFIX/lib/ocaml
|
||||
S .
|
||||
S ../lib
|
||||
FLG -w -40
|
||||
# Processing lib/.merlin
|
||||
B $LIB_PREFIX/lib/bytes
|
||||
B $LIB_PREFIX/lib/findlib
|
||||
|
@ -28,6 +16,18 @@
|
|||
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
|
||||
B $LIB_PREFIX/lib/ocaml
|
||||
B ../_build/default/exe/.x.eobjs
|
||||
B ../_build/default/lib/.foo.objs
|
||||
S $LIB_PREFIX/lib/bytes
|
||||
S $LIB_PREFIX/lib/findlib
|
||||
S $LIB_PREFIX/lib/ocaml
|
||||
S .
|
||||
S ../lib
|
||||
FLG -w -40
|
||||
|
||||
Make sure a ppx directive is generated
|
||||
|
||||
|
|
|
@ -2,5 +2,22 @@
|
|||
File "dune", line 44, characters 19-42:
|
||||
Warning: Directory dir-that-doesnt-exist doesn't exist.
|
||||
diff alias runtest
|
||||
diff alias runtest
|
||||
diff alias runtest
|
||||
diff alias runtest (exit 1)
|
||||
(cd _build/default && /usr/bin/diff -u result expected)
|
||||
--- result 2018-07-09 21:13:11.000000000 +0700
|
||||
+++ expected 2018-07-09 21:13:11.000000000 +0700
|
||||
@@ -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 21:13:11.000000000 +0700
|
||||
+++ expected2 2018-07-09 21:13:11.000000000 +0700
|
||||
@@ -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