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

54
src/dune_project.ml
View File

@ -159,14 +159,11 @@ module Lang = struct
end end
module Extension = struct module Extension = struct
type maker = type maker = project -> Stanza.Parser.t list Sexp.Of_sexp.cstr_parser
T : ('a, Stanza.Parser.t list) Sexp.Of_sexp.Constructor_args_spec.t *
(project -> 'a)
-> maker
type t = Syntax.Version.t * maker 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 let extensions = Hashtbl.create 32
@ -176,22 +173,13 @@ module Extension = struct
[ "name", Sexp.To_sexp.string name ]; [ "name", Sexp.To_sexp.string name ];
Hashtbl.add extensions name (Syntax.Versioned_parser.make versions) Hashtbl.add extensions name (Syntax.Versioned_parser.make versions)
let parse project entries = let lookup (name_loc, name) (ver_loc, ver) =
match String.Map.of_list entries with match Hashtbl.find extensions name with
| Error (name, _, (loc, _, _)) -> | None ->
Loc.fail loc "Exntesion %S specified for the second time." name Loc.fail name_loc "Unknown extension %S.%s" name
| Ok _ -> (hint name (Hashtbl.keys extensions))
List.concat_map entries ~f:(fun (name, (loc, (ver_loc, ver), args)) -> | Some versions ->
match Hashtbl.find extensions name with Syntax.Versioned_parser.find_exn versions ~loc:ver_loc ~data_version:ver
| 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))
end end
let filename = "dune-project" let filename = "dune-project"
@ -243,13 +231,6 @@ let parse ~dir ~lang_stanzas ~packages ~file =
record record
(name ~dir ~packages >>= fun name -> (name ~dir ~packages >>= fun name ->
field_o "version" string >>= fun version -> 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 = let t =
{ kind = Dune { kind = Dune
; name ; name
@ -260,8 +241,21 @@ let parse ~dir ~lang_stanzas ~packages ~file =
; project_file = Some file ; project_file = Some file
} }
in in
let extenstions_stanzas = Extension.parse t extensions in dup_field_multi "using"
t.stanza_parser <- Sexp.Of_sexp.sum (lang_stanzas t @ extenstions_stanzas); (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) return t)
let load_dune_project ~dir packages = 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 *) (** One version of an extension *)
type t type t
(** [make version args_spec f] defines one version of an (** [make version parser] defines one version of an extension. Users will
extension. Users will enable this extension by writing: enable this extension by writing:
{[ (using <name> <version> <args>) ]} {[ (using <name> <version> <args>) ]}
in their [dune-project] file. [args_spec] is used to describe in their [dune-project] file. [parser] is used to describe
what [<args>] might be. what [<args>] might be. *)
*)
val make val make
: Syntax.Version.t : Syntax.Version.t
-> ('a, Stanza.Parser.t list) Sexp.Of_sexp.Constructor_args_spec.t -> (project -> Stanza.Parser.t list Sexp.Of_sexp.cstr_parser)
-> (project -> 'a)
-> t -> t
(** Register all the supported versions of an extension *) (** Register all the supported versions of an extension *)

2
src/file_tree.ml
View File

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

4
src/inline_tests.ml
View File

@ -27,7 +27,7 @@ module Backend = struct
let short = None let short = None
let parse = let parse =
record record
(record_loc >>= fun loc -> (list_loc >>= fun loc ->
field "runner_libraries" (list (located string)) ~default:[] field "runner_libraries" (list (located string)) ~default:[]
>>= fun runner_libraries -> >>= fun runner_libraries ->
Ordered_set_lang.Unexpanded.field "flags" >>= fun flags -> Ordered_set_lang.Unexpanded.field "flags" >>= fun flags ->
@ -135,7 +135,7 @@ include Sub_system.Register_end_point(
let short = Some empty let short = Some empty
let parse = let parse =
record record
(record_loc >>= fun loc -> (list_loc >>= fun loc ->
field "deps" (list Dep_conf.t) ~default:[] >>= fun deps -> field "deps" (list Dep_conf.t) ~default:[] >>= fun deps ->
Ordered_set_lang.Unexpanded.field "flags" >>= fun flags -> Ordered_set_lang.Unexpanded.field "flags" >>= fun flags ->
field_o "backend" (located string) >>= fun backend -> 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" of_sexp_error sexp "Unsupported version, only version 1 is supported"
in in
sum sum
[ cstr "dune" (version @> list raw @> nil) [ "dune",
(fun () l -> parse_sub_systems l) (next version >>= fun () ->
next (list raw) >>| fun l ->
parse_sub_systems l)
] ]
let load fname = of_sexp (Io.Sexp.load ~mode:Single fname) 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 t = let t =
let cstr_sw name f = let sw = String_with_vars.t in
cstr name (String_with_vars.t @> nil) f
in
sum sum
[ cstr_sw "file" (fun x -> File x) [ "file" , (next sw >>| fun x -> File x)
; cstr_sw "alias" (fun x -> Alias x) ; "alias" , (next sw >>| fun x -> Alias x)
; cstr_sw "alias_rec" (fun x -> Alias_rec x) ; "alias_rec" , (next sw >>| fun x -> Alias_rec x)
; cstr_sw "glob_files" (fun x -> Glob_files x) ; "glob_files" , (next sw >>| fun x -> Glob_files x)
; cstr_sw "files_recursively_in" (fun x -> Files_recursively_in x) ; "files_recursively_in" , (next sw >>| fun x -> Files_recursively_in x)
; cstr_sw "package" (fun x -> Package x) ; "package" , (next sw >>| fun x -> Package x)
; cstr "universe" nil Universe ; "universe" , return Universe
] ]
in in
fun sexp -> fun sexp ->
@ -257,12 +255,15 @@ module Preprocess = struct
let t = let t =
sum sum
[ cstr "no_preprocessing" nil No_preprocessing [ "no_preprocessing", return No_preprocessing
; cstr "action" (located Action.Unexpanded.t @> nil) (fun (loc, x) -> ; "action",
Action (loc, x)) (next (located Action.Unexpanded.t) >>| fun (loc, x) ->
; cstr "pps" (cstr_loc (list Pp_or_flags.t @> nil)) (fun loc l -> Action (loc, x))
let pps, flags = Pp_or_flags.split l in ; "pps",
Pps { loc; pps; flags }) (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 let pps = function
@ -469,7 +470,7 @@ module Buildable = struct
field name Ordered_set_lang.t ~default:Ordered_set_lang.standard field name Ordered_set_lang.t ~default:Ordered_set_lang.standard
let v1 = let v1 =
record_loc >>= fun loc -> list_loc >>= fun loc ->
field "preprocess" Preprocess_map.t ~default:Preprocess_map.default field "preprocess" Preprocess_map.t ~default:Preprocess_map.default
>>= fun preprocess -> >>= fun preprocess ->
field "preprocessor_deps" (list Dep_conf.t) ~default:[] field "preprocessor_deps" (list Dep_conf.t) ~default:[]
@ -1261,40 +1262,62 @@ module Stanzas = struct
type Stanza.t += Include of Loc.t * string 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 = let common project ~syntax : constructors =
[ cstr "library" (Library.v1 project @> nil) (fun x -> [Library x]) [ "library",
; cstr "executable" (Executables.single project ~syntax @> nil) execs (next (Library.v1 project) >>| fun x ->
; cstr "executables" (Executables.multi project ~syntax @> nil) execs [Library x])
; cstr "rule" (cstr_loc (Rule.v1 @> nil)) (fun loc x -> [Rule { x with loc }]) ; "executable" , next (Executables.single project ~syntax) >>| execs
; cstr "ocamllex" (cstr_loc (Rule.ocamllex_v1 @> nil)) ; "executables", next (Executables.multi project ~syntax) >>| execs
(fun loc x -> rules (Rule.ocamllex_to_rule loc x)) ; "rule",
; cstr "ocamlyacc" (cstr_loc (Rule.ocamlyacc_v1 @> nil)) (list_loc >>= fun loc ->
(fun loc x -> rules (Rule.ocamlyacc_to_rule loc x)) next Rule.v1 >>| fun x ->
; cstr "menhir" (cstr_loc (Menhir.v1 @> nil)) [Rule { x with loc }])
(fun loc x -> [Menhir { x with loc }]) ; "ocamllex",
; cstr "install" (Install_conf.v1 project @> nil) (fun x -> [Install x]) (list_loc >>= fun loc ->
; cstr "alias" (Alias_conf.v1 project @> nil) (fun x -> [Alias x]) next Rule.ocamllex_v1 >>| fun x ->
; cstr "copy_files" (Copy_files.v1 @> nil) rules (Rule.ocamllex_to_rule loc x))
(fun glob -> [Copy_files {add_line_directive = false; glob}]) ; "ocamlyacc",
; cstr "copy_files#" (Copy_files.v1 @> nil) (list_loc >>= fun loc ->
(fun glob -> [Copy_files {add_line_directive = true; glob}]) next Rule.ocamlyacc_v1 >>| fun x ->
; cstr "include" (cstr_loc (relative_file @> nil)) (fun loc fn -> rules (Rule.ocamlyacc_to_rule loc x))
[Include (loc, fn)]) ; "menhir",
; cstr "documentation" (Documentation.v1 project @> nil) (list_loc >>= fun loc ->
(fun d -> [Documentation d]) 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 = let dune project =
common project ~syntax:Dune @ common project ~syntax:Dune @
[ cstr "env" (cstr_loc (rest Env.rule)) [ "env",
(fun loc rules -> [Env { loc; rules }]) (list_loc >>= fun loc ->
rest Env.rule >>| fun rules ->
[Env { loc; rules }])
] ]
let jbuild project = let jbuild project =
common project ~syntax:Jbuild @ common project ~syntax:Jbuild @
[ cstr "jbuild_version" (Jbuild_version.t @> nil) (fun _ -> []) [ "jbuild_version", (next Jbuild_version.t >>| fun _ -> [])
] ]
let () = let () =

2
src/preprocessing.ml
View File

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

2
src/stanza.ml
View File

@ -3,5 +3,5 @@ open Stdune
type t = .. type t = ..
module Parser = struct 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 end

2
src/stanza.mli
View File

@ -9,5 +9,5 @@ module Parser : sig
Each stanza in a configuration file might produce several values Each stanza in a configuration file might produce several values
of type [t], hence the [t list] here. *) 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 end

9
src/stdune/path.ml
View File

@ -594,10 +594,11 @@ let t = function
| s -> | s ->
let open Sexp.Of_sexp in let open Sexp.Of_sexp in
sum sum
[ cstr "In_build_dir" (Local.t @> nil) in_build_dir [ "In_build_dir" , next Local.t >>| in_build_dir
; cstr "In_source_tree" (Local.t @> nil) in_source_tree ; "In_source_tree", next Local.t >>| in_source_tree
; cstr "External" (External.t @> nil) external_ ; "External" , next External.t >>| external_
] s ]
s
let sexp_of_t t = let sexp_of_t t =
let constr f x y = Sexp.To_sexp.(pair string f) (x, y) in 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_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 ?hint sexp fmt = Printf.ksprintf (of_sexp_error ?hint sexp) fmt
let of_sexp_errorf_loc loc fmt = let of_sexp_errorf_loc ?hint loc fmt =
Printf.ksprintf (fun s -> raise (Of_sexp (loc, s, None))) fmt Printf.ksprintf (fun s -> raise (Of_sexp (loc, s, hint))) fmt
let raw x = x let raw x = x
@ -158,49 +158,53 @@ module Of_sexp = struct
module Name_map = Map.Make(Name) module Name_map = Map.Make(Name)
type record_parser_state = (* Either:
{ loc : Loc.t
; unparsed : unparsed_field Name_map.t
; known : string list
}
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 return x state = (x, state)
let (>>=) m f state = let (>>=) m f state =
let x, state = m state in let x, state = m state in
f x state f x state
let (>>|) m f state =
let x, state = m state in
(f x, state)
let record_loc state = let get_loc : type k. k list_parser_state -> Loc.t = function
(state.loc, state) | Cstr (loc, _, _) -> loc
| Record (loc, _, _) -> loc
let consume name state = let list_loc state = (get_loc state, state)
{ state with
unparsed = Name_map.remove state.unparsed name
; known = name :: state.known
}
let add_known name state = let consume name (Record (loc, unparsed, known)) =
{ state with known = name :: state.known } Record (loc, Name_map.remove unparsed name, name :: known)
let ignore_fields names state = let add_known name (Record (loc, unparsed, known)) =
let unparsed = (Record (loc, unparsed, name :: known))
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 map_validate parse ~f state = let map_validate parse ~f state1 =
let x, state' = parse state in let x, state2 = parse state1 in
match f x with match f x with
| Result.Ok x -> x, state' | Result.Ok x -> x, state2
| Error msg -> | Error msg ->
let (Record (_, unparsed1, _)) = state1 in
let (Record (_, unparsed2, _)) = state2 in
let parsed = 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 match before, after with
| Some _, None -> before | Some _, None -> before
| _ -> None) | _ -> None)
@ -212,7 +216,7 @@ module Of_sexp = struct
|> List.sort ~compare:(fun a b -> |> List.sort ~compare:(fun a b ->
Int.compare a.Loc.start.pos_cnum b.start.pos_cnum) Int.compare a.Loc.start.pos_cnum b.start.pos_cnum)
with with
| [] -> state.loc | [] -> get_loc state1
| first :: l -> | first :: l ->
let last = List.fold_left l ~init:first ~f:(fun _ x -> x) in let last = List.fold_left l ~init:first ~f:(fun _ x -> x) in
{ first with stop = last.stop } { 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 of_sexp_errorf_loc (Ast.loc field.entry) "too many values for field %s" name
let field_missing state 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 = let rec multiple_occurrences ~name ~last ~prev =
match prev.prev with 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 of_sexp_errorf last.entry "Field %S is present too many times" name
[@@inline never] [@@inline never]
let find_single state name = let find_single (Record (_, unparsed, _)) name =
let res = Name_map.find state.unparsed name in let res = Name_map.find unparsed name in
(match res with (match res with
| Some ({ prev = Some prev; _ } as last) -> | Some ({ prev = Some prev; _ } as last) ->
multiple_occurrences ~name ~last ~prev multiple_occurrences ~name ~last ~prev
@ -294,40 +298,31 @@ module Of_sexp = struct
| Some f -> | Some f ->
too_many_values name f too_many_values name f
in 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) (res, consume name state)
let make_record_parser_state sexp = let parse_fields m loc sexps =
match sexp with let unparsed =
| Atom _ | Quoted_string _ -> of_sexp_error sexp "List expected" List.fold_left sexps ~init:Name_map.empty ~f:(fun acc sexp ->
| List (loc, sexps) -> match sexp with
let unparsed = | List (_, name_sexp :: values) -> begin
List.fold_left sexps ~init:Name_map.empty ~f:(fun acc sexp -> match name_sexp with
match sexp with | Atom (_, A name) ->
| List (_, name_sexp :: values) -> begin Name_map.add acc name
match name_sexp with { values
| Atom (_, A name) -> ; entry = sexp
Name_map.add acc name ; prev = Name_map.find acc name
{ values }
; entry = sexp | List _ | Quoted_string _ ->
; prev = Name_map.find acc name of_sexp_error name_sexp "Atom expected"
} end
| List _ | Quoted_string _ -> | _ ->
of_sexp_error name_sexp "Atom expected" of_sexp_error sexp
end "S-expression of the form (<name> <values>...) expected")
| _ -> in
of_sexp_error sexp let v, (Record (_, unparsed, known)) = m (Record (loc, unparsed, [])) in
"S-expression of the form (<name> <values>...) expected") match Name_map.choose unparsed with
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
| None -> v | None -> v
| Some (name, { entry; _ }) -> | Some (name, { entry; _ }) ->
let name_sexp = let name_sexp =
@ -335,129 +330,89 @@ module Of_sexp = struct
| List (_, s :: _) -> s | List (_, s :: _) -> s
| _ -> assert false | _ -> assert false
in in
of_sexp_errorf ~hint:({ on = name ; candidates = state.known}) of_sexp_errorf ~hint:({ on = name ; candidates = known})
name_sexp "Unknown field %s" name name_sexp "Unknown field %s" name
module Constructor_args_spec = struct let record m sexp =
type 'a conv = 'a t match sexp with
type ('a, 'b) t = | Atom _ | Quoted_string _ -> of_sexp_error sexp "List expected"
| Nil : ('a, 'a) t | List (loc, sexps) -> parse_fields m loc sexps
| 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 rec convert : type a b. (a, b) t -> Ast.t -> Ast.t list -> a -> b let next t (Cstr (loc, cstr, sexps)) =
= fun t sexp sexps f -> match sexps with
match t, sexps with | [] -> of_sexp_errorf_loc loc "Not enough arguments for %s" cstr
| Nil, [] -> f | sexp :: sexps ->
| Rest conv, l -> f (List.map l ~f:conv) let v = t sexp in
| Record rp, l -> begin (v, Cstr (loc, cstr, sexps))
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 parse t sexp f = let rest t (Cstr (loc, cstr, sexps)) =
match sexp with (List.map sexps ~f:t,
| Atom _ | Quoted_string _ -> Cstr (loc, cstr, []))
of_sexp_error sexp "List expected"
| List (_, l) -> convert t sexp l f
end
let nil = Constructor_args_spec.Nil let rest_as_record m (Cstr (loc, cstr, sexps)) =
let ( @> ) a b = Constructor_args_spec.Cons (a, b) let v = parse_fields m loc sexps in
let rest f = Constructor_args_spec.Rest f (v, Cstr (loc, cstr, []))
let cstr_loc x = Constructor_args_spec.Loc x
let rest_as_record rp = Constructor_args_spec.Record rp
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 match find_single state name with
| Some { values; entry; _ } -> | Some { values; entry; _ } ->
(Constructor_args_spec.convert args_spec entry values f, (sum_result (m (Cstr (Ast.loc entry, name, values))),
consume name state) consume name state)
| None -> | None ->
match default with match default with
| Some v -> (v, add_known name state) | Some v -> (v, add_known name state)
| None -> field_missing state name | 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 = let rec loop acc field =
match field with match field with
| None -> acc | None -> acc
| Some { values; entry; prev } -> | Some { values; entry; prev } ->
let x = let x = sum_result (m (Cstr (Ast.loc entry, name, values))) in
Constructor_args_spec.convert args_spec entry values f
in
loop (x :: acc) prev loop (x :: acc) prev
in 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) (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 = let enum cstrs sexp =
match sexp with match sexp with
| Quoted_string _ | List _ -> of_sexp_error sexp "Atom expected" | Quoted_string _ | List _ -> of_sexp_error sexp "Atom expected"
| Atom (_, A s) -> | Atom (_, A s) ->
match match List.assoc cstrs s with
List.find cstrs ~f:(fun (name, _) -> | Some value -> value
equal_cstr_name name s)
with
| Some (_, value) -> value
| None -> | None ->
of_sexp_errorf sexp of_sexp_errorf sexp
~hint:{ on = String.uncapitalize s ~hint:{ on = s
; candidates =List.map cstrs ~f:(fun (name, _) -> ; candidates = List.map cstrs ~f:fst
String.uncapitalize name) } }
"Unknown value %s" s "Unknown value %s" s
end end

116
src/stdune/sexp.mli
View File

@ -74,13 +74,57 @@ module Of_sexp : sig
val raw : ast t val raw : ast t
(* Record parsing monad *) val enum : (string * 'a) list -> 'a t
type 'a record_parser
val return : 'a -> 'a record_parser
val ( >>= ) : 'a record_parser -> ('a -> 'b record_parser) -> 'b record_parser
(** Return the location of the record being parsed *) (** {2 Parsing lists} *)
val record_loc : Loc.t record_parser
(** 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 module Short_syntax : sig
type 'a t = type 'a t =
@ -109,69 +153,19 @@ module Of_sexp : sig
-> 'a t -> 'a t
-> 'a list record_parser -> '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 *) (** Field that takes multiple values *)
val field_multi val field_multi
: string : string
-> ?default:'b -> ?default:'a
-> ('a, 'b) Constructor_args_spec.t -> 'a cstr_parser
-> 'a -> 'a record_parser
-> 'b record_parser
(** A field that can appear multiple times and each time takes (** A field that can appear multiple times and each time takes
multiple values *) multiple values *)
val dup_field_multi val dup_field_multi
: string : string
-> ('a, 'b) Constructor_args_spec.t -> 'a cstr_parser
-> 'a -> 'a list record_parser
-> '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
end end
module type Sexpable = sig 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) | List (_, List _ :: _) as sexp -> Opam (record (Opam.t ~profile) sexp)
| sexp -> | sexp ->
sum sum
[ cstr "default" [ "default",
(rest_as_record (Default.t ~profile)) (rest_as_record (Default.t ~profile) >>| fun x ->
(fun x -> Default x) Default x)
; cstr "opam" ; "opam",
(rest_as_record (Opam.t ~profile)) (rest_as_record (Opam.t ~profile) >>| fun x ->
(fun x -> Opam x) Opam x)
] ]
sexp sexp
@ -96,8 +96,11 @@ type item = Context of Sexp.Ast.t | Profile of Loc.t * string
let item_of_sexp = let item_of_sexp =
sum sum
[ cstr "context" (raw @> nil) (fun x -> Context x) [ "context", (next raw >>|fun x -> Context x)
; cstr "profile" (cstr_loc (string @> nil)) (fun loc x -> Profile (loc, x)) ; "profile",
(list_loc >>= fun loc ->
next string >>= fun x ->
return (Profile (loc, x)))
] ]
let t ?x ?profile:cmdline_profile sexps = let t ?x ?profile:cmdline_profile sexps =