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:
parent
d01b6c8ab1
commit
3c74bf07e8
|
@ -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 ->
|
||||
[ "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))
|
||||
; 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",
|
||||
(next path >>= fun src ->
|
||||
next path >>| fun dst ->
|
||||
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 })
|
||||
; "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
|
||||
|
||||
|
|
|
@ -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)) ->
|
||||
let lookup (name_loc, name) (ver_loc, ver) =
|
||||
match Hashtbl.find extensions name with
|
||||
| None ->
|
||||
Loc.fail loc "Unknown extension %S.%s" name
|
||||
Loc.fail name_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))
|
||||
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 =
|
||||
|
|
|
@ -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 *)
|
||||
|
|
|
@ -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 ->
|
||||
|
|
|
@ -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 ->
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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,10 +255,13 @@ module Preprocess = struct
|
|||
|
||||
let t =
|
||||
sum
|
||||
[ cstr "no_preprocessing" nil No_preprocessing
|
||||
; cstr "action" (located Action.Unexpanded.t @> nil) (fun (loc, x) ->
|
||||
[ "no_preprocessing", return No_preprocessing
|
||||
; "action",
|
||||
(next (located Action.Unexpanded.t) >>| fun (loc, x) ->
|
||||
Action (loc, x))
|
||||
; cstr "pps" (cstr_loc (list Pp_or_flags.t @> nil)) (fun loc l ->
|
||||
; "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 })
|
||||
]
|
||||
|
@ -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 ->
|
||||
[ "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)])
|
||||
; cstr "documentation" (Documentation.v1 project @> nil)
|
||||
(fun d -> [Documentation d])
|
||||
; "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 () =
|
||||
|
|
|
@ -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 ->
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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,13 +298,11 @@ 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 parse_fields m loc sexps =
|
||||
let unparsed =
|
||||
List.fold_left sexps ~init:Name_map.empty ~f:(fun acc sexp ->
|
||||
match sexp with
|
||||
|
@ -319,15 +321,8 @@ module Of_sexp = struct
|
|||
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 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 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
|
||||
let record m sexp =
|
||||
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"
|
||||
| Atom _ | Quoted_string _ -> of_sexp_error sexp "List expected"
|
||||
| List (loc, sexps) -> parse_fields m loc sexps
|
||||
|
||||
let parse t sexp f =
|
||||
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 rest t (Cstr (loc, cstr, sexps)) =
|
||||
(List.map sexps ~f:t,
|
||||
Cstr (loc, cstr, []))
|
||||
|
||||
let rest_as_record m (Cstr (loc, cstr, sexps)) =
|
||||
let v = parse_fields m loc sexps in
|
||||
(v, Cstr (loc, cstr, []))
|
||||
|
||||
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 _ | Quoted_string _ ->
|
||||
of_sexp_error sexp "List expected"
|
||||
| List (_, l) -> convert t sexp l f
|
||||
end
|
||||
| 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 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 field_multi name ?default args_spec f state =
|
||||
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
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 =
|
||||
|
|
Loading…
Reference in New Issue