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 t elem =
|
||||||
let binding =
|
let binding =
|
||||||
peek_exn >>= function
|
peek_exn >>= function
|
||||||
| Atom (loc, A s) when String.length s > 1 && s.[0] = ':' ->
|
| List (_, Atom (loc, A s) :: _) when
|
||||||
begin
|
String.length s > 1 && s.[0] = ':' ->
|
||||||
string >>= fun name ->
|
binding elem >>| fun (name, values) ->
|
||||||
peek >>= function
|
Left (name, (loc, values))
|
||||||
| None -> of_sexp_errorf loc "Naked binding %s" s
|
|
||||||
| Some _ ->
|
|
||||||
elem >>| fun elem ->
|
|
||||||
Left (name, (loc, elem))
|
|
||||||
end
|
|
||||||
| _ ->
|
| _ ->
|
||||||
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 (named, unnamed) = List.partition_map bindings ~f:(fun x -> x) in
|
||||||
{ unnamed = List.flatten unnamed
|
{ unnamed
|
||||||
; named =
|
; named =
|
||||||
(match String.Map.of_list named with
|
(match String.Map.of_list named with
|
||||||
| Ok x -> x
|
| Ok x -> x
|
||||||
|
@ -331,15 +326,6 @@ module Dep_conf = struct
|
||||||
let t =
|
let t =
|
||||||
make_dep_parser ~single:(fun x -> x) ~many:(sum dep_cons)
|
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
|
open Sexp
|
||||||
let sexp_of_t = function
|
let sexp_of_t = function
|
||||||
| File t ->
|
| File t ->
|
||||||
|
@ -1202,7 +1188,7 @@ module Rule = struct
|
||||||
>>= fun action ->
|
>>= fun action ->
|
||||||
field "targets" (list file_in_current_dir)
|
field "targets" (list file_in_current_dir)
|
||||||
>>= fun targets ->
|
>>= fun targets ->
|
||||||
field "deps" Dep_conf.bindings ~default:Named.empty
|
field "deps" (Named.t Dep_conf.t) ~default:Named.empty
|
||||||
>>= fun deps ->
|
>>= fun deps ->
|
||||||
field "locks" (list String_with_vars.t) ~default:[] >>= fun locks ->
|
field "locks" (list String_with_vars.t) ~default:[] >>= fun locks ->
|
||||||
map_validate
|
map_validate
|
||||||
|
@ -1421,7 +1407,7 @@ module Alias_conf = struct
|
||||||
field_o "package" Pkg.t >>= fun package ->
|
field_o "package" Pkg.t >>= fun package ->
|
||||||
field_o "action" (located Action.Unexpanded.t) >>= fun action ->
|
field_o "action" (located Action.Unexpanded.t) >>= fun action ->
|
||||||
field "locks" (list String_with_vars.t) ~default:[] >>= fun locks ->
|
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 ->
|
>>= fun deps ->
|
||||||
return
|
return
|
||||||
{ name
|
{ name
|
||||||
|
@ -1445,7 +1431,7 @@ module Tests = struct
|
||||||
(Buildable.t >>= fun buildable ->
|
(Buildable.t >>= fun buildable ->
|
||||||
field_oslu "link_flags" >>= fun link_flags ->
|
field_oslu "link_flags" >>= fun link_flags ->
|
||||||
names >>= fun names ->
|
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_o "package" Pkg.t >>= fun package ->
|
||||||
field "locks" (list String_with_vars.t) ~default:[] >>= fun locks ->
|
field "locks" (list String_with_vars.t) ~default:[] >>= fun locks ->
|
||||||
field "modes" Executables.Link_mode.Set.t
|
field "modes" Executables.Link_mode.Set.t
|
||||||
|
|
|
@ -380,6 +380,26 @@ module Of_sexp = struct
|
||||||
}
|
}
|
||||||
"Unknown constructor %s" name
|
"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 =
|
let sum cstrs =
|
||||||
next_with_user_context (fun uc sexp ->
|
next_with_user_context (fun uc sexp ->
|
||||||
match sexp with
|
match sexp with
|
||||||
|
|
|
@ -201,6 +201,8 @@ module Of_sexp : sig
|
||||||
list parser. *)
|
list parser. *)
|
||||||
val sum : (string * 'a t) list -> 'a t
|
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
|
(** Check the result of a list parser, and raise a properly located
|
||||||
error in case of failure. *)
|
error in case of failure. *)
|
||||||
val map_validate
|
val map_validate
|
||||||
|
|
|
@ -1,5 +1,5 @@
|
||||||
|
|
||||||
(rule
|
(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)
|
(targets bar)
|
||||||
(action (with-stdout-to bar (echo "foo"))))
|
(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.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 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
|
# Processing lib/.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 .
|
||||||
FLG -ppx '$PPX/fooppx@./ppx.exe --as-ppx --cookie '\''library-name="foo"'\'''
|
FLG -ppx '$PPX/fooppx@./ppx.exe --as-ppx --cookie '\''library-name="foo"'\'''
|
||||||
FLG -open Foo -w -40 -open Bar -w -40
|
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
|
Make sure a ppx directive is generated
|
||||||
|
|
||||||
|
|
|
@ -2,5 +2,22 @@
|
||||||
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
|
diff alias runtest (exit 1)
|
||||||
diff alias runtest
|
(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