matthieu
/
dune
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Use the same monad to parse all list of S-expressions (#882) 

Signed-off-by: Jeremie Dimino <jeremie@dimino.org>
This commit is contained in:
Jérémie Dimino 2018-06-14 08:51:27 +01:00 committed by GitHub
parent d01b6c8ab1
commit 3c74bf07e8
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
14 changed files with 358 additions and 352 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

98
src/action.ml
View File

@ -24,37 +24,73 @@ struct
let rec t sexp =
let path = Path.t and string = String.t in
sum
[ cstr "run" (Program.t @> rest string) (fun prog args -> Run (prog, args))
; cstr "chdir" (path @> t @> nil) (fun dn t -> Chdir (dn, t))
; cstr "setenv" (string @> string @> t @> nil) (fun k v t -> Setenv (k, v, t))
; cstr "with-stdout-to" (path @> t @> nil) (fun fn t -> Redirect (Stdout, fn, t))
; cstr "with-stderr-to" (path @> t @> nil) (fun fn t -> Redirect (Stderr, fn, t))
; cstr "with-outputs-to" (path @> t @> nil) (fun fn t -> Redirect (Outputs, fn, t))
; cstr "ignore-stdout" (t @> nil) (fun t -> Ignore (Stdout, t))
; cstr "ignore-stderr" (t @> nil) (fun t -> Ignore (Stderr, t))
; cstr "ignore-outputs" (t @> nil) (fun t -> Ignore (Outputs, t))
; cstr "progn" (rest t) (fun l -> Progn l)
; cstr "echo" (string @> rest string) (fun x xs -> Echo (x::xs))
; cstr "cat" (path @> nil) (fun x -> Cat x)
; cstr "copy" (path @> path @> nil) (fun src dst -> Copy (src, dst))
(*
(* We don't expose symlink to the user yet since this might complicate things *)
; cstr "symlink" (a @> a @> nil) (fun src dst -> Symlink (dst, Cat src))
*)
; cstr "copy#" (path @> path @> nil) (fun src dst ->
Copy_and_add_line_directive (src, dst))
; cstr "copy-and-add-line-directive" (cstr_loc (path @> path @> nil)) (fun loc src dst ->
Loc.warn loc "copy-and-add-line-directive is deprecated, use copy# instead";
Copy_and_add_line_directive (src, dst))
; cstr "copy#" (path @> path @> nil) (fun src dst ->
Copy_and_add_line_directive (src, dst))
; cstr "system" (string @> nil) (fun cmd -> System cmd)
; cstr "bash" (string @> nil) (fun cmd -> Bash cmd)
; cstr "write-file" (path @> string @> nil) (fun fn s -> Write_file (fn, s))
; cstr "diff" (path @> path @> nil)
(fun file1 file2 -> Diff { optional = false; file1; file2 })
; cstr "diff?" (path @> path @> nil)
(fun file1 file2 -> Diff { optional = true ; file1; file2 })
[ "run",
(next Program.t >>= fun prog ->
rest string >>| fun args ->
Run (prog, args))
; "chdir",
(next path >>= fun dn ->
next t >>| fun t ->
Chdir (dn, t))
; "setenv",
(next string >>= fun k ->
next string >>= fun v ->
next t >>| fun t ->
Setenv (k, v, t))
; "with-stdout-to",
(next path >>= fun fn ->
next t >>| fun t ->
Redirect (Stdout, fn, t))
; "with-stderr-to",
(next path >>= fun fn ->
next t >>| fun t ->
Redirect (Stderr, fn, t))
; "with-outputs-to",
(next path >>= fun fn ->
next t >>| fun t ->
Redirect (Outputs, fn, t))
; "ignore-stdout",
(next t >>| fun t -> Ignore (Stdout, t))
; "ignore-stderr",
(next t >>| fun t -> Ignore (Stderr, t))
; "ignore-outputs",
(next t >>| fun t -> Ignore (Outputs, t))
; "progn",
(rest t >>| fun l -> Progn l)
; "echo",
(next string >>= fun x ->
rest string >>| fun xs ->
Echo (x :: xs))
; "cat",
(next path >>| fun x -> Cat x)
; "copy",
(next path >>= fun src ->
next path >>| fun dst ->
Copy (src, dst))
; "copy#",
(next path >>= fun src ->
next path >>| fun dst ->
Copy_and_add_line_directive (src, dst))
; "copy-and-add-line-directive",
(next path >>= fun src ->
next path >>| fun dst ->
Copy_and_add_line_directive (src, dst))
; "system",
(next string >>| fun cmd -> System cmd)
; "bash",
(next string >>| fun cmd -> Bash cmd)
; "write-file",
(next path >>= fun fn ->
next string >>| fun s ->
Write_file (fn, s))
; "diff",
(next path >>= fun file1 ->
next path >>| fun file2 ->
Diff { optional = false; file1; file2 })
; "diff?",
(next path >>= fun file1 ->
next path >>| fun file2 ->
Diff { optional = true; file1; file2 })
]
sexp

54
src/dune_project.ml
View File

@ -159,14 +159,11 @@ module Lang = struct
end
module Extension = struct
type maker =
T : ('a, Stanza.Parser.t list) Sexp.Of_sexp.Constructor_args_spec.t *
(project -> 'a)
-> maker
type maker = project -> Stanza.Parser.t list Sexp.Of_sexp.cstr_parser
type t = Syntax.Version.t * maker
let make ver args_spec f = (ver, T (args_spec, f))
let make ver f = (ver, f)
let extensions = Hashtbl.create 32
@ -176,22 +173,13 @@ module Extension = struct
[ "name", Sexp.To_sexp.string name ];
Hashtbl.add extensions name (Syntax.Versioned_parser.make versions)
let parse project entries =
match String.Map.of_list entries with
| Error (name, _, (loc, _, _)) ->
Loc.fail loc "Exntesion %S specified for the second time." name
| Ok _ ->
List.concat_map entries ~f:(fun (name, (loc, (ver_loc, ver), args)) ->
match Hashtbl.find extensions name with
| None ->
Loc.fail loc "Unknown extension %S.%s" name
(hint name (Hashtbl.keys extensions))
| Some versions ->
let (T (spec, f)) =
Syntax.Versioned_parser.find_exn versions
~loc:ver_loc ~data_version:ver
in
Sexp.Of_sexp.Constructor_args_spec.parse spec args (f project))
let lookup (name_loc, name) (ver_loc, ver) =
match Hashtbl.find extensions name with
| None ->
Loc.fail name_loc "Unknown extension %S.%s" name
(hint name (Hashtbl.keys extensions))
| Some versions ->
Syntax.Versioned_parser.find_exn versions ~loc:ver_loc ~data_version:ver
end
let filename = "dune-project"
@ -243,13 +231,6 @@ let parse ~dir ~lang_stanzas ~packages ~file =
record
(name ~dir ~packages >>= fun name ->
field_o "version" string >>= fun version ->
dup_field_multi "using"
(located string
@> located Syntax.Version.t
@> cstr_loc (rest raw))
(fun (loc, name) ver args_loc args ->
(name, (loc, ver, Sexp.Ast.List (args_loc, args))))
>>= fun extensions ->
let t =
{ kind = Dune
; name
@ -260,8 +241,21 @@ let parse ~dir ~lang_stanzas ~packages ~file =
; project_file = Some file
}
in
let extenstions_stanzas = Extension.parse t extensions in
t.stanza_parser <- Sexp.Of_sexp.sum (lang_stanzas t @ extenstions_stanzas);
dup_field_multi "using"
(list_loc >>= fun loc ->
next (located string) >>= fun name ->
next (located Syntax.Version.t) >>= fun ver ->
Extension.lookup name ver t >>= fun stanzas ->
return (snd name, (loc, stanzas)))
>>= fun extensions ->
let extensions_stanzas =
match String.Map.of_list extensions with
| Error (name, _, (loc, _)) ->
Loc.fail loc "Extension %S specified for the second time." name
| Ok _ ->
List.concat_map extensions ~f:(fun (_, (_, x)) -> x)
in
t.stanza_parser <- Sexp.Of_sexp.sum (lang_stanzas t @ extensions_stanzas);
return t)
let load_dune_project ~dir packages =

12
src/dune_project.mli
View File

@ -73,18 +73,16 @@ module Extension : sig
(** One version of an extension *)
type t
(** [make version args_spec f] defines one version of an
extension. Users will enable this extension by writing:
(** [make version parser] defines one version of an extension. Users will
enable this extension by writing:
{[ (using <name> <version> <args>) ]}
in their [dune-project] file. [args_spec] is used to describe
what [<args>] might be.
*)
in their [dune-project] file. [parser] is used to describe
what [<args>] might be. *)
val make
: Syntax.Version.t
-> ('a, Stanza.Parser.t list) Sexp.Of_sexp.Constructor_args_spec.t
-> (project -> 'a)
-> (project -> Stanza.Parser.t list Sexp.Of_sexp.cstr_parser)
-> t
(** Register all the supported versions of an extension *)

2
src/file_tree.ml
View File

@ -52,7 +52,7 @@ module Dune_file = struct
dn
in
sum
[ cstr "ignored_subdirs" (list sub_dir @> nil) String.Set.of_list
[ "ignored_subdirs", next (list sub_dir) >>| String.Set.of_list
]
in
fun sexps ->

4
src/inline_tests.ml
View File

@ -27,7 +27,7 @@ module Backend = struct
let short = None
let parse =
record
(record_loc >>= fun loc ->
(list_loc >>= fun loc ->
field "runner_libraries" (list (located string)) ~default:[]
>>= fun runner_libraries ->
Ordered_set_lang.Unexpanded.field "flags" >>= fun flags ->
@ -135,7 +135,7 @@ include Sub_system.Register_end_point(
let short = Some empty
let parse =
record
(record_loc >>= fun loc ->
(list_loc >>= fun loc ->
field "deps" (list Dep_conf.t) ~default:[] >>= fun deps ->
Ordered_set_lang.Unexpanded.field "flags" >>= fun flags ->
field_o "backend" (located string) >>= fun backend ->

6
src/installed_dune_file.ml
View File

@ -35,8 +35,10 @@ let of_sexp =
of_sexp_error sexp "Unsupported version, only version 1 is supported"
in
sum
[ cstr "dune" (version @> list raw @> nil)
(fun () l -> parse_sub_systems l)
[ "dune",
(next version >>= fun () ->
next (list raw) >>| fun l ->
parse_sub_systems l)
]
let load fname = of_sexp (Io.Sexp.load ~mode:Single fname)

105
src/jbuild.ml
View File

@ -208,17 +208,15 @@ module Dep_conf = struct
let t =
let t =
let cstr_sw name f =
cstr name (String_with_vars.t @> nil) f
in
let sw = String_with_vars.t in
sum
[ cstr_sw "file" (fun x -> File x)
; cstr_sw "alias" (fun x -> Alias x)
; cstr_sw "alias_rec" (fun x -> Alias_rec x)
; cstr_sw "glob_files" (fun x -> Glob_files x)
; cstr_sw "files_recursively_in" (fun x -> Files_recursively_in x)
; cstr_sw "package" (fun x -> Package x)
; cstr "universe" nil Universe
[ "file" , (next sw >>| fun x -> File x)
; "alias" , (next sw >>| fun x -> Alias x)
; "alias_rec" , (next sw >>| fun x -> Alias_rec x)
; "glob_files" , (next sw >>| fun x -> Glob_files x)
; "files_recursively_in" , (next sw >>| fun x -> Files_recursively_in x)
; "package" , (next sw >>| fun x -> Package x)
; "universe" , return Universe
]
in
fun sexp ->
@ -257,12 +255,15 @@ module Preprocess = struct
let t =
sum
[ cstr "no_preprocessing" nil No_preprocessing
; cstr "action" (located Action.Unexpanded.t @> nil) (fun (loc, x) ->
Action (loc, x))
; cstr "pps" (cstr_loc (list Pp_or_flags.t @> nil)) (fun loc l ->
let pps, flags = Pp_or_flags.split l in
Pps { loc; pps; flags })
[ "no_preprocessing", return No_preprocessing
; "action",
(next (located Action.Unexpanded.t) >>| fun (loc, x) ->
Action (loc, x))
; "pps",
(list_loc >>= fun loc ->
next (list Pp_or_flags.t) >>| fun l ->
let pps, flags = Pp_or_flags.split l in
Pps { loc; pps; flags })
]
let pps = function
@ -469,7 +470,7 @@ module Buildable = struct
field name Ordered_set_lang.t ~default:Ordered_set_lang.standard
let v1 =
record_loc >>= fun loc ->
list_loc >>= fun loc ->
field "preprocess" Preprocess_map.t ~default:Preprocess_map.default
>>= fun preprocess ->
field "preprocessor_deps" (list Dep_conf.t) ~default:[]
@ -1261,40 +1262,62 @@ module Stanzas = struct
type Stanza.t += Include of Loc.t * string
type constructors = Stanza.t list Sexp.Of_sexp.Constructor_spec.t list
type constructors = (string * Stanza.t list Sexp.Of_sexp.cstr_parser) list
let common project ~syntax : constructors =
[ cstr "library" (Library.v1 project @> nil) (fun x -> [Library x])
; cstr "executable" (Executables.single project ~syntax @> nil) execs
; cstr "executables" (Executables.multi project ~syntax @> nil) execs
; cstr "rule" (cstr_loc (Rule.v1 @> nil)) (fun loc x -> [Rule { x with loc }])
; cstr "ocamllex" (cstr_loc (Rule.ocamllex_v1 @> nil))
(fun loc x -> rules (Rule.ocamllex_to_rule loc x))
; cstr "ocamlyacc" (cstr_loc (Rule.ocamlyacc_v1 @> nil))
(fun loc x -> rules (Rule.ocamlyacc_to_rule loc x))
; cstr "menhir" (cstr_loc (Menhir.v1 @> nil))
(fun loc x -> [Menhir { x with loc }])
; cstr "install" (Install_conf.v1 project @> nil) (fun x -> [Install x])
; cstr "alias" (Alias_conf.v1 project @> nil) (fun x -> [Alias x])
; cstr "copy_files" (Copy_files.v1 @> nil)
(fun glob -> [Copy_files {add_line_directive = false; glob}])
; cstr "copy_files#" (Copy_files.v1 @> nil)
(fun glob -> [Copy_files {add_line_directive = true; glob}])
; cstr "include" (cstr_loc (relative_file @> nil)) (fun loc fn ->
[Include (loc, fn)])
; cstr "documentation" (Documentation.v1 project @> nil)
(fun d -> [Documentation d])
[ "library",
(next (Library.v1 project) >>| fun x ->
[Library x])
; "executable" , next (Executables.single project ~syntax) >>| execs
; "executables", next (Executables.multi project ~syntax) >>| execs
; "rule",
(list_loc >>= fun loc ->
next Rule.v1 >>| fun x ->
[Rule { x with loc }])
; "ocamllex",
(list_loc >>= fun loc ->
next Rule.ocamllex_v1 >>| fun x ->
rules (Rule.ocamllex_to_rule loc x))
; "ocamlyacc",
(list_loc >>= fun loc ->
next Rule.ocamlyacc_v1 >>| fun x ->
rules (Rule.ocamlyacc_to_rule loc x))
; "menhir",
(list_loc >>= fun loc ->
next Menhir.v1 >>| fun x ->
[Menhir { x with loc }])
; "install",
(next (Install_conf.v1 project) >>| fun x ->
[Install x])
; "alias",
(next (Alias_conf.v1 project) >>| fun x ->
[Alias x])
; "copy_files",
(next Copy_files.v1 >>| fun glob ->
[Copy_files {add_line_directive = false; glob}])
; "copy_files#",
(next Copy_files.v1 >>| fun glob ->
[Copy_files {add_line_directive = true; glob}])
; "include",
(list_loc >>= fun loc ->
next relative_file >>| fun fn ->
[Include (loc, fn)])
; "documentation",
(next (Documentation.v1 project) >>| fun d ->
[Documentation d])
]
let dune project =
common project ~syntax:Dune @
[ cstr "env" (cstr_loc (rest Env.rule))
(fun loc rules -> [Env { loc; rules }])
[ "env",
(list_loc >>= fun loc ->
rest Env.rule >>| fun rules ->
[Env { loc; rules }])
]
let jbuild project =
common project ~syntax:Jbuild @
[ cstr "jbuild_version" (Jbuild_version.t @> nil) (fun _ -> [])
[ "jbuild_version", (next Jbuild_version.t >>| fun _ -> [])
]
let () =

2
src/preprocessing.ml
View File

@ -37,7 +37,7 @@ module Driver = struct
let short = None
let parse =
record
(record_loc >>= fun loc ->
(list_loc >>= fun loc ->
Ordered_set_lang.Unexpanded.field "flags" >>= fun flags ->
Ordered_set_lang.Unexpanded.field "lint_flags" >>= fun lint_flags ->
field "main" string >>= fun main ->

2
src/stanza.ml
View File

@ -3,5 +3,5 @@ open Stdune
type t = ..
module Parser = struct
type nonrec t = t list Sexp.Of_sexp.Constructor_spec.t
type nonrec t = string * t list Sexp.Of_sexp.cstr_parser
end

2
src/stanza.mli
View File

@ -9,5 +9,5 @@ module Parser : sig
Each stanza in a configuration file might produce several values
of type [t], hence the [t list] here. *)
type nonrec t = t list Sexp.Of_sexp.Constructor_spec.t
type nonrec t = string * t list Sexp.Of_sexp.cstr_parser
end

9
src/stdune/path.ml
View File

@ -594,10 +594,11 @@ let t = function
| s ->
let open Sexp.Of_sexp in
sum
[ cstr "In_build_dir" (Local.t @> nil) in_build_dir
; cstr "In_source_tree" (Local.t @> nil) in_source_tree
; cstr "External" (External.t @> nil) external_
] s
[ "In_build_dir" , next Local.t >>| in_build_dir
; "In_source_tree", next Local.t >>| in_source_tree
; "External" , next External.t >>| external_
]
s
let sexp_of_t t =
let constr f x y = Sexp.To_sexp.(pair string f) (x, y) in

279
src/stdune/sexp.ml
View File

@ -80,8 +80,8 @@ module Of_sexp = struct
let of_sexp_error ?hint sexp str = raise (Of_sexp (Ast.loc sexp, str, hint))
let of_sexp_errorf ?hint sexp fmt = Printf.ksprintf (of_sexp_error ?hint sexp) fmt
let of_sexp_errorf_loc loc fmt =
Printf.ksprintf (fun s -> raise (Of_sexp (loc, s, None))) fmt
let of_sexp_errorf_loc ?hint loc fmt =
Printf.ksprintf (fun s -> raise (Of_sexp (loc, s, hint))) fmt
let raw x = x
@ -158,49 +158,53 @@ module Of_sexp = struct
module Name_map = Map.Make(Name)
type record_parser_state =
{ loc : Loc.t
; unparsed : unparsed_field Name_map.t
; known : string list
}
(* Either:
type 'a record_parser = record_parser_state -> 'a * record_parser_state
- [Sum (<list location>, <constructor name>, <elements>)]
- [Record (<list location>, <unparsed fields>, <known field names>)]
*)
type 'kind list_parser_state =
| Cstr
: Loc.t * string * Ast.t list -> [`Cstr] list_parser_state
| Record
: Loc.t * unparsed_field Name_map.t * string list
-> [`Record] list_parser_state
type ('a, 'kind) list_parser
= 'kind list_parser_state -> 'a * 'kind list_parser_state
type 'a cstr_parser = ('a, [`Cstr ]) list_parser
type 'a record_parser = ('a, [`Record]) list_parser
let return x state = (x, state)
let (>>=) m f state =
let x, state = m state in
f x state
let (>>|) m f state =
let x, state = m state in
(f x, state)
let record_loc state =
(state.loc, state)
let get_loc : type k. k list_parser_state -> Loc.t = function
| Cstr (loc, _, _) -> loc
| Record (loc, _, _) -> loc
let consume name state =
{ state with
unparsed = Name_map.remove state.unparsed name
; known = name :: state.known
}
let list_loc state = (get_loc state, state)
let add_known name state =
{ state with known = name :: state.known }
let consume name (Record (loc, unparsed, known)) =
Record (loc, Name_map.remove unparsed name, name :: known)
let ignore_fields names state =
let unparsed =
List.fold_left names ~init:state.unparsed ~f:(fun acc name ->
Name_map.remove acc name)
in
((),
{ state with
unparsed
; known = List.rev_append names state.known
})
let add_known name (Record (loc, unparsed, known)) =
(Record (loc, unparsed, name :: known))
let map_validate parse ~f state =
let x, state' = parse state in
let map_validate parse ~f state1 =
let x, state2 = parse state1 in
match f x with
| Result.Ok x -> x, state'
| Result.Ok x -> x, state2
| Error msg ->
let (Record (_, unparsed1, _)) = state1 in
let (Record (_, unparsed2, _)) = state2 in
let parsed =
Name_map.merge state.unparsed state'.unparsed ~f:(fun _key before after ->
Name_map.merge unparsed1 unparsed2 ~f:(fun _key before after ->
match before, after with
| Some _, None -> before
| _ -> None)
@ -212,7 +216,7 @@ module Of_sexp = struct
|> List.sort ~compare:(fun a b ->
Int.compare a.Loc.start.pos_cnum b.start.pos_cnum)
with
| [] -> state.loc
| [] -> get_loc state1
| first :: l ->
let last = List.fold_left l ~init:first ~f:(fun _ x -> x) in
{ first with stop = last.stop }
@ -236,7 +240,7 @@ module Of_sexp = struct
of_sexp_errorf_loc (Ast.loc field.entry) "too many values for field %s" name
let field_missing state name =
of_sexp_errorf_loc state.loc "field %s missing" name
of_sexp_errorf_loc (get_loc state) "field %s missing" name
let rec multiple_occurrences ~name ~last ~prev =
match prev.prev with
@ -247,8 +251,8 @@ module Of_sexp = struct
of_sexp_errorf last.entry "Field %S is present too many times" name
[@@inline never]
let find_single state name =
let res = Name_map.find state.unparsed name in
let find_single (Record (_, unparsed, _)) name =
let res = Name_map.find unparsed name in
(match res with
| Some ({ prev = Some prev; _ } as last) ->
multiple_occurrences ~name ~last ~prev
@ -294,40 +298,31 @@ module Of_sexp = struct
| Some f ->
too_many_values name f
in
let res = loop [] (Name_map.find state.unparsed name) in
let (Record (_, unparsed, _)) = state in
let res = loop [] (Name_map.find unparsed name) in
(res, consume name state)
let make_record_parser_state sexp =
match sexp with
| Atom _ | Quoted_string _ -> of_sexp_error sexp "List expected"
| List (loc, sexps) ->
let unparsed =
List.fold_left sexps ~init:Name_map.empty ~f:(fun acc sexp ->
match sexp with
| List (_, name_sexp :: values) -> begin
match name_sexp with
| Atom (_, A name) ->
Name_map.add acc name
{ values
; entry = sexp
; prev = Name_map.find acc name
}
| List _ | Quoted_string _ ->
of_sexp_error name_sexp "Atom expected"
end
| _ ->
of_sexp_error sexp
"S-expression of the form (<name> <values>...) expected")
in
{ loc = loc
; known = []
; unparsed
}
let record parse sexp =
let state = make_record_parser_state sexp in
let v, state = parse state in
match Name_map.choose state.unparsed with
let parse_fields m loc sexps =
let unparsed =
List.fold_left sexps ~init:Name_map.empty ~f:(fun acc sexp ->
match sexp with
| List (_, name_sexp :: values) -> begin
match name_sexp with
| Atom (_, A name) ->
Name_map.add acc name
{ values
; entry = sexp
; prev = Name_map.find acc name
}
| List _ | Quoted_string _ ->
of_sexp_error name_sexp "Atom expected"
end
| _ ->
of_sexp_error sexp
"S-expression of the form (<name> <values>...) expected")
in
let v, (Record (_, unparsed, known)) = m (Record (loc, unparsed, [])) in
match Name_map.choose unparsed with
| None -> v
| Some (name, { entry; _ }) ->
let name_sexp =
@ -335,129 +330,89 @@ module Of_sexp = struct
| List (_, s :: _) -> s
| _ -> assert false
in
of_sexp_errorf ~hint:({ on = name ; candidates = state.known})
of_sexp_errorf ~hint:({ on = name ; candidates = known})
name_sexp "Unknown field %s" name
module Constructor_args_spec = struct
type 'a conv = 'a t
type ('a, 'b) t =
| Nil : ('a, 'a) t
| Rest : 'a conv -> ('a list -> 'b, 'b) t
| Record : 'a record_parser -> ('a -> 'b, 'b) t
| Loc : ('a, 'b) t -> (Loc.t -> 'a, 'b) t
| Cons : 'a conv * ('b, 'c) t -> ('a -> 'b, 'c) t
let record m sexp =
match sexp with
| Atom _ | Quoted_string _ -> of_sexp_error sexp "List expected"
| List (loc, sexps) -> parse_fields m loc sexps
let rec convert : type a b. (a, b) t -> Ast.t -> Ast.t list -> a -> b
= fun t sexp sexps f ->
match t, sexps with
| Nil, [] -> f
| Rest conv, l -> f (List.map l ~f:conv)
| Record rp, l -> begin
match sexp with
| Atom (_, A s) | Quoted_string (_, s) ->
of_sexp_errorf sexp "'%s' expect arguments" s
| List (loc, _) ->
f (record rp (List (loc, l)))
end
| Loc t, l -> convert t sexp l (f (Ast.loc sexp))
| Cons (conv, t), s :: l -> convert t sexp l (f (conv s))
| Cons _, [] -> of_sexp_error sexp "not enough arguments"
| Nil, _ :: _ -> of_sexp_error sexp "too many arguments"
let next t (Cstr (loc, cstr, sexps)) =
match sexps with
| [] -> of_sexp_errorf_loc loc "Not enough arguments for %s" cstr
| sexp :: sexps ->
let v = t sexp in
(v, Cstr (loc, cstr, sexps))
let parse t sexp f =
match sexp with
| Atom _ | Quoted_string _ ->
of_sexp_error sexp "List expected"
| List (_, l) -> convert t sexp l f
end
let rest t (Cstr (loc, cstr, sexps)) =
(List.map sexps ~f:t,
Cstr (loc, cstr, []))
let nil = Constructor_args_spec.Nil
let ( @> ) a b = Constructor_args_spec.Cons (a, b)
let rest f = Constructor_args_spec.Rest f
let cstr_loc x = Constructor_args_spec.Loc x
let rest_as_record rp = Constructor_args_spec.Record rp
let rest_as_record m (Cstr (loc, cstr, sexps)) =
let v = parse_fields m loc sexps in
(v, Cstr (loc, cstr, []))
let field_multi name ?default args_spec f state =
let sum_result (v, Cstr (loc, cstr, sexps)) =
match sexps with
| [] -> v
| _ :: _ -> of_sexp_errorf_loc loc "Too many arguments for %s" cstr
let find_cstr cstrs loc name state =
match List.assoc cstrs name with
| Some m -> sum_result (m state)
| None ->
of_sexp_errorf_loc loc
~hint:{ on = name
; candidates = List.map cstrs ~f:fst
}
"Unknown constructor %s" name
let sum cstrs sexp =
match sexp with
| Atom (loc, A s) ->
find_cstr cstrs loc s (Cstr (loc, s, []))
| Quoted_string _ -> of_sexp_error sexp "Atom expected"
| List (_, []) -> of_sexp_error sexp "non-empty list expected"
| List (loc, name :: args) ->
match name with
| Quoted_string _ | List _ -> of_sexp_error name "Atom expected"
| Atom (s_loc, A s) ->
find_cstr cstrs s_loc s (Cstr (loc, s, args))
let field_multi name ?default m state =
match find_single state name with
| Some { values; entry; _ } ->
(Constructor_args_spec.convert args_spec entry values f,
(sum_result (m (Cstr (Ast.loc entry, name, values))),
consume name state)
| None ->
match default with
| Some v -> (v, add_known name state)
| None -> field_missing state name
let dup_field_multi name args_spec f state =
let dup_field_multi name m state =
let rec loop acc field =
match field with
| None -> acc
| Some { values; entry; prev } ->
let x =
Constructor_args_spec.convert args_spec entry values f
in
let x = sum_result (m (Cstr (Ast.loc entry, name, values))) in
loop (x :: acc) prev
in
let res = loop [] (Name_map.find state.unparsed name) in
let (Record (_, unparsed, _)) = state in
let res = loop [] (Name_map.find unparsed name) in
(res, consume name state)
module Constructor_spec = struct
type ('a, 'b) unpacked =
{ name : string
; args : ('a, 'b) Constructor_args_spec.t
; make : 'a
}
type 'a t = T : (_, 'a) unpacked -> 'a t [@@unboxed]
let name (T t) = t.name
end
module C = Constructor_spec
let cstr name args make = C.T { name; args; make }
let equal_cstr_name a b = Name.compare a b = Eq
let find_cstr cstrs sexp name =
match
List.find cstrs ~f:(fun cstr ->
equal_cstr_name (C.name cstr) name)
with
| Some cstr -> cstr
| None ->
of_sexp_errorf sexp
~hint:{ on = String.uncapitalize name
; candidates = List.map cstrs ~f:C.name
}
"Unknown constructor %s" name
let sum cstrs sexp =
match sexp with
| Atom (_, A s) ->
let (C.T cstr) = find_cstr cstrs sexp s in
Constructor_args_spec.convert cstr.args sexp [] cstr.make
| Quoted_string _ -> of_sexp_error sexp "Atom expected"
| List (_, []) -> of_sexp_error sexp "non-empty list expected"
| List (_, name_sexp :: args) ->
match name_sexp with
| Quoted_string _ | List _ -> of_sexp_error name_sexp "Atom expected"
| Atom (_, A s) ->
let (C.T cstr) = find_cstr cstrs sexp s in
Constructor_args_spec.convert cstr.args sexp args cstr.make
let enum cstrs sexp =
match sexp with
| Quoted_string _ | List _ -> of_sexp_error sexp "Atom expected"
| Atom (_, A s) ->
match
List.find cstrs ~f:(fun (name, _) ->
equal_cstr_name name s)
with
| Some (_, value) -> value
match List.assoc cstrs s with
| Some value -> value
| None ->
of_sexp_errorf sexp
~hint:{ on = String.uncapitalize s
; candidates =List.map cstrs ~f:(fun (name, _) ->
String.uncapitalize name) }
~hint:{ on = s
; candidates = List.map cstrs ~f:fst
}
"Unknown value %s" s
end

116
src/stdune/sexp.mli
View File

@ -74,13 +74,57 @@ module Of_sexp : sig
val raw : ast t
(* Record parsing monad *)
type 'a record_parser
val return : 'a -> 'a record_parser
val ( >>= ) : 'a record_parser -> ('a -> 'b record_parser) -> 'b record_parser
val enum : (string * 'a) list -> 'a t
(** Return the location of the record being parsed *)
val record_loc : Loc.t record_parser
(** {2 Parsing lists} *)
(** Monad for parsing lists *)
type ('a, 'kind) list_parser
type 'a cstr_parser = ('a, [`Cstr ]) list_parser
type 'a record_parser = ('a, [`Record]) list_parser
val return : 'a -> ('a, _) list_parser
val ( >>= )
: ('a, 'kind) list_parser
-> ('a -> ('b, 'kind) list_parser)
-> ('b, 'kind) list_parser
val ( >>| )
: ('a, 'kind) list_parser
-> ('a -> 'b)
-> ('b, 'kind) list_parser
(** Return the location of the list being parsed *)
val list_loc : (Loc.t, _) list_parser
(** Parser that parse a record, i.e. a list of s-expressions of the
form [(<atom> <s-exp>)]. *)
val record : 'a record_parser -> 'a t
(** Parser that parse a S-expression of the form [(<atom> <s-exp1>
<s-exp2> ...)] or [<atom>]. [<atom>] is looked up in the list and
the remaining s-expressions are parsed using the corresponding
list parser. *)
val sum : (string * 'a cstr_parser) list -> 'a t
(** Parse and consume the next element of the list *)
val next : 'a t -> 'a cstr_parser
(** Parse and consume the rest of the list as a list of element of
the same type. *)
val rest : 'a t -> 'a list cstr_parser
(** Parse all remaining elements as a list of fields *)
val rest_as_record : 'a record_parser -> 'a cstr_parser
(** Check the result of a list parser, and raise a properly located
error in case of failure. *)
val map_validate
: 'a record_parser
-> f:('a -> ('b, string) Result.t)
-> 'b record_parser
(** {3 Parsing record fields} *)
module Short_syntax : sig
type 'a t =
@ -109,69 +153,19 @@ module Of_sexp : sig
-> 'a t
-> 'a list record_parser
val map_validate
: 'a record_parser
-> f:('a -> ('b, string) Result.result)
-> 'b record_parser
val ignore_fields : string list -> unit record_parser
val record : 'a record_parser -> 'a t
module Constructor_spec : sig
type 'a t
end
module Constructor_args_spec : sig
type ('a, 'b) t
val parse : ('a, 'b) t -> Ast.t -> 'a -> 'b
end
val nil : ('a, 'a) Constructor_args_spec.t
val ( @> )
: 'a t
-> ('b, 'c) Constructor_args_spec.t
-> ('a -> 'b, 'c) Constructor_args_spec.t
(** Parse all remaining arguments using the following parser *)
val rest : 'a t -> ('a list -> 'b, 'b) Constructor_args_spec.t
(** Parse all remaining arguments using the following record parser *)
val rest_as_record : 'a record_parser -> ('a -> 'b, 'b) Constructor_args_spec.t
(** Capture the location of the constructor *)
val cstr_loc
: ('a, 'b) Constructor_args_spec.t
-> (Loc.t -> 'a, 'b) Constructor_args_spec.t
(** Field that takes multiple values *)
val field_multi
: string
-> ?default:'b
-> ('a, 'b) Constructor_args_spec.t
-> 'a
-> 'b record_parser
-> ?default:'a
-> 'a cstr_parser
-> 'a record_parser
(** A field that can appear multiple times and each time takes
multiple values *)
val dup_field_multi
: string
-> ('a, 'b) Constructor_args_spec.t
-> 'a
-> 'b list record_parser
val cstr
: string
-> ('a, 'b) Constructor_args_spec.t
-> 'a
-> 'b Constructor_spec.t
val sum
: 'a Constructor_spec.t list
-> 'a t
val enum : (string * 'a) list -> 'a t
-> 'a cstr_parser
-> 'a list record_parser
end
module type Sexpable = sig

19
src/workspace.ml
View File

@ -63,12 +63,12 @@ module Context = struct
| List (_, List _ :: _) as sexp -> Opam (record (Opam.t ~profile) sexp)
| sexp ->
sum
[ cstr "default"
(rest_as_record (Default.t ~profile))
(fun x -> Default x)
; cstr "opam"
(rest_as_record (Opam.t ~profile))
(fun x -> Opam x)
[ "default",
(rest_as_record (Default.t ~profile) >>| fun x ->
Default x)
; "opam",
(rest_as_record (Opam.t ~profile) >>| fun x ->
Opam x)
]
sexp
@ -96,8 +96,11 @@ type item = Context of Sexp.Ast.t | Profile of Loc.t * string
let item_of_sexp =
sum
[ cstr "context" (raw @> nil) (fun x -> Context x)
; cstr "profile" (cstr_loc (string @> nil)) (fun loc x -> Profile (loc, x))
[ "context", (next raw >>|fun x -> Context x)
; "profile",
(list_loc >>= fun loc ->
next string >>= fun x ->
return (Profile (loc, x)))
]
let t ?x ?profile:cmdline_profile sexps =