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

Merge pull request #893 from diml/sexp-context 

User context in S-expression parsers
This commit is contained in:
Rudi Grinberg 2018-06-20 13:00:34 +06:30 committed by GitHub
parent 4922faf18a 3e2567d2c7
commit f1a56e3baf
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
18 changed files with 204 additions and 188 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
src/action.ml
View File

@ -626,7 +626,8 @@ module Promotion = struct
let load_db () =
if Path.exists db_file then
Sexp.Of_sexp.(
parse (list File.t) (Io.Sexp.load db_file ~mode:Many_as_one))
parse (list File.t) Univ_map.empty
(Io.Sexp.load db_file ~mode:Many_as_one))
else
[]

5
src/build_system.ml
View File

@ -19,7 +19,7 @@ module Promoted_to_delete = struct
let load () =
if Path.exists fn then
Io.Sexp.load fn ~mode:Many
|> List.map ~f:(Sexp.Of_sexp.parse Path.t)
|> List.map ~f:(Sexp.Of_sexp.parse Path.t Univ_map.empty)
else
[]
@ -1220,7 +1220,8 @@ let update_universe t =
Utils.Cached_digest.remove universe_file;
let n =
if Path.exists universe_file then
Sexp.Of_sexp.(parse int) (Io.Sexp.load ~mode:Single universe_file) + 1
Sexp.Of_sexp.(parse int) Univ_map.empty
(Io.Sexp.load ~mode:Single universe_file) + 1
else
0
in

2
src/config.ml
View File

@ -115,7 +115,7 @@ let user_config_file =
"dune/config"
let load_config_file p =
(Sexp.Of_sexp.parse t) (Io.Sexp.load p ~mode:Many_as_one)
(Sexp.Of_sexp.parse t Univ_map.empty) (Io.Sexp.load p ~mode:Many_as_one)
let load_user_config_file () =
if Path.exists user_config_file then

2
src/context.ml
View File

@ -425,7 +425,7 @@ let create_for_opam ?root ~env ~targets ~profile ~switch ~name
>>= fun s ->
let vars =
Usexp.parse_string ~fname:"<opam output>" ~mode:Single s
|> Sexp.Of_sexp.(parse (list (pair string string)))
|> Sexp.Of_sexp.(parse (list (pair string string)) Univ_map.empty)
|> Env.Map.of_list_multi
|> Env.Map.mapi ~f:(fun var values ->
match List.rev values with

106
src/dune_project.ml
View File

@ -112,19 +112,17 @@ end = struct
end
type t =
{ kind : Kind.t
; name : Name.t
; root : Path.Local.t
; version : string option
; packages : Package.t Package.Name.Map.t
; mutable stanza_parser : Stanza.t list Sexp.Of_sexp.t
; mutable project_file : Path.t option
{ kind : Kind.t
; name : Name.t
; root : Path.Local.t
; version : string option
; packages : Package.t Package.Name.Map.t
; stanza_parser : Stanza.t list Sexp.Of_sexp.t
; mutable project_file : Path.t option
}
type project = t
module Lang = struct
type t = Syntax.Version.t * (project -> Stanza.Parser.t list)
type t = Syntax.Version.t * Stanza.Parser.t list
let make ver f = (ver, f)
@ -143,7 +141,7 @@ module Lang = struct
} = first_line
in
let ver =
Sexp.Of_sexp.parse Syntax.Version.t
Sexp.Of_sexp.parse Syntax.Version.t Univ_map.empty
(Atom (ver_loc, Sexp.Atom.of_string ver)) in
match Hashtbl.find langs name with
| None ->
@ -161,9 +159,7 @@ module Lang = struct
end
module Extension = struct
type maker = project -> Stanza.Parser.t list Sexp.Of_sexp.t
type t = Syntax.Version.t * maker
type t = Syntax.Version.t * Stanza.Parser.t list Sexp.Of_sexp.t
let make ver f = (ver, f)
@ -184,6 +180,15 @@ module Extension = struct
Syntax.Versioned_parser.find_exn versions ~loc:ver_loc ~data_version:ver
end
let key = Univ_map.Key.create ()
let set t = Sexp.Of_sexp.set key t
let get_exn () =
let open Sexp.Of_sexp in
get key >>| function
| Some t -> t
| None ->
Exn.code_error "Current project is unset" []
let filename = "dune-project"
let get_local_path p =
@ -191,23 +196,15 @@ let get_local_path p =
| External _ -> assert false
| Local p -> p
let fake_stanza_parser =
let open Sexp.Of_sexp in
return () >>| fun _ -> assert false
let anonymous = lazy(
let t =
{ kind = Dune
; name = Name.anonymous_root
; packages = Package.Name.Map.empty
; root = get_local_path Path.root
; version = None
; stanza_parser = fake_stanza_parser
; project_file = None
}
in
t.stanza_parser <- Sexp.Of_sexp.sum (snd (Lang.latest "dune") t);
t)
let anonymous = lazy (
{ kind = Dune
; name = Name.anonymous_root
; packages = Package.Name.Map.empty
; root = get_local_path Path.root
; version = None
; stanza_parser = Sexp.Of_sexp.sum (snd (Lang.latest "dune"))
; project_file = None
})
let default_name ~dir ~packages =
match Package.Name.Map.choose packages with
@ -237,21 +234,11 @@ let parse ~dir ~lang_stanzas ~packages ~file =
record
(name ~dir ~packages >>= fun name ->
field_o "version" string >>= fun version ->
let t =
{ kind = Dune
; name
; root = get_local_path dir
; version
; packages
; stanza_parser = fake_stanza_parser
; project_file = Some file
}
in
multi_field "using"
(loc >>= fun loc ->
located string >>= fun name ->
located Syntax.Version.t >>= fun ver ->
Extension.lookup name ver t >>= fun stanzas ->
Extension.lookup name ver >>= fun stanzas ->
return (snd name, (loc, stanzas)))
>>= fun extensions ->
let extensions_stanzas =
@ -261,29 +248,33 @@ let parse ~dir ~lang_stanzas ~packages ~file =
| 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
{ kind = Dune
; name
; root = get_local_path dir
; version
; packages
; stanza_parser = Sexp.Of_sexp.sum (lang_stanzas @ extensions_stanzas)
; project_file = Some file
})
let load_dune_project ~dir packages =
let fname = Path.relative dir filename in
Io.with_lexbuf_from_file fname ~f:(fun lb ->
let lang_stanzas = Lang.parse (Dune_lexer.first_line lb) in
let sexp = Sexp.Parser.parse lb ~mode:Many_as_one in
Sexp.Of_sexp.parse (parse ~dir ~lang_stanzas ~packages ~file:fname) sexp)
Sexp.Of_sexp.parse (parse ~dir ~lang_stanzas ~packages ~file:fname)
Univ_map.empty sexp)
let make_jbuilder_project ~dir packages =
let t =
{ kind = Jbuilder
; name = default_name ~dir ~packages
; root = get_local_path dir
; version = None
; packages
; stanza_parser = fake_stanza_parser
; project_file = None
}
in
t.stanza_parser <- Sexp.Of_sexp.sum (snd (Lang.latest "dune") t);
t
{ kind = Jbuilder
; name = default_name ~dir ~packages
; root = get_local_path dir
; version = None
; packages
; stanza_parser = Sexp.Of_sexp.sum (snd (Lang.latest "dune"))
; project_file = None
}
let load ~dir ~files =
let packages =
@ -343,4 +334,3 @@ let append_to_project_file t str =
output_string oc s;
let len = String.length s in
if len > 0 && s.[len - 1] <> '\n' then output_char oc '\n'))

36
src/dune_project.mli
View File

@ -31,18 +31,16 @@ end
(* CR-soon diml: make this abstract *)
type t = private
{ kind : Kind.t
; name : Name.t
; root : Path.Local.t
; version : string option
; packages : Package.t Package.Name.Map.t
; mutable stanza_parser : Stanza.t list Sexp.Of_sexp.t
; mutable project_file : Path.t option
{ kind : Kind.t
; name : Name.t
; root : Path.Local.t
; version : string option
; packages : Package.t Package.Name.Map.t
; stanza_parser : Stanza.t list Sexp.Of_sexp.t
; mutable project_file : Path.t option
}
module Lang : sig
type project = t
(** One version of a language *)
type t
@ -53,10 +51,7 @@ module Lang : sig
as the first line of their [dune-project] file. [stanza_parsers]
defines what stanzas the user can write in [dune] files. *)
val make
: Syntax.Version.t
-> (project -> Stanza.Parser.t list)
-> t
val make : Syntax.Version.t -> Stanza.Parser.t list -> t
val version : t -> Syntax.Version.t
@ -65,11 +60,9 @@ module Lang : sig
(** Latest version of the following language *)
val latest : string -> t
end with type project := t
end
module Extension : sig
type project = t
(** One version of an extension *)
type t
@ -80,14 +73,11 @@ module Extension : sig
in their [dune-project] file. [parser] is used to describe
what [<args>] might be. *)
val make
: Syntax.Version.t
-> (project -> Stanza.Parser.t list Sexp.Of_sexp.t)
-> t
val make : Syntax.Version.t -> Stanza.Parser.t list Sexp.Of_sexp.t -> t
(** Register all the supported versions of an extension *)
val register : string -> t list -> unit
end with type project := t
end
(** Load a project description from the following directory. [files]
is the set of files in this directory. *)
@ -105,3 +95,7 @@ val ensure_project_file_exists : t -> unit
(** Append the following text to the project file *)
val append_to_project_file : t -> string -> unit
(** Set the project we are currently parsing dune files for *)
val set : t -> ('a, 'k) Sexp.Of_sexp.parser -> ('a, 'k) Sexp.Of_sexp.parser
val get_exn : unit -> (t, 'k) Sexp.Of_sexp.parser

2
src/file_tree.ml
View File

@ -60,7 +60,7 @@ module Dune_file = struct
List.partition_map sexps ~f:(fun sexp ->
match (sexp : Sexp.Ast.t) with
| List (_, (Atom (_, A "ignored_subdirs") :: _)) ->
Left (Sexp.Of_sexp.parse stanza sexp)
Left (Sexp.Of_sexp.parse stanza Univ_map.empty sexp)
| _ -> Right sexp)
in
let ignored_subdirs =

8
src/installed_dune_file.ml
View File

@ -3,7 +3,8 @@ open Import
let parse_sub_systems sexps =
List.filter_map sexps ~f:(fun sexp ->
let name, ver, data =
Sexp.Of_sexp.(parse (triple string (located Syntax.Version.t) raw)) sexp
Sexp.Of_sexp.(parse (triple string (located Syntax.Version.t) raw)
Univ_map.empty) sexp
in
match Sub_system_name.get name with
| None ->
@ -24,7 +25,7 @@ let parse_sub_systems sexps =
Syntax.Versioned_parser.find_exn M.parsers ~loc:vloc
~data_version:ver
in
M.T (Sexp.Of_sexp.parse parser data))
M.T (Sexp.Of_sexp.parse parser Univ_map.empty data))
let of_sexp =
let open Sexp.Of_sexp in
@ -42,7 +43,8 @@ let of_sexp =
parse_sub_systems l)
]
let load fname = Sexp.Of_sexp.parse of_sexp (Io.Sexp.load ~mode:Single fname)
let load fname =
Sexp.Of_sexp.parse of_sexp Univ_map.empty (Io.Sexp.load ~mode:Single fname)
let gen confs =
let sexps =

107
src/jbuild.ml
View File

@ -1,13 +1,11 @@
open Import
open Sexp.Of_sexp
(* This file defines the jbuild types as well as the S-expression syntax for the various
supported version of the specification.
[vN] is for the version [N] of the specification and [vjs] is for the rolling
[jane_street] version, when needed.
(* This file defines the jbuild types as well as the S-expression
syntax for the various supported version of the specification.
*)
(* Deprecated *)
module Jbuild_version = struct
type t =
| V1
@ -16,8 +14,6 @@ module Jbuild_version = struct
enum
[ "1", V1
]
let latest_stable = V1
end
let invalid_module_name ~loc =
@ -154,13 +150,15 @@ module Pkg = struct
(hint name_s (Package.Name.Map.keys project.packages
|> List.map ~f:Package.Name.to_string)))
let t p =
let t =
Dune_project.get_exn () >>= fun p ->
located Package.Name.t >>| fun (loc, name) ->
match resolve p name with
| Ok x -> x
| Error e -> Loc.fail loc "%s" e
let field p =
let field =
Dune_project.get_exn () >>= fun p ->
map_validate (field_o "package" string) ~f:(function
| None -> default p
| Some name -> resolve p (Package.Name.of_string name))
@ -500,7 +498,7 @@ module Buildable = struct
let modules_field name =
field name Ordered_set_lang.t ~default:Ordered_set_lang.standard
let v1 =
let t =
loc >>= fun loc ->
field "preprocess" Preprocess_map.t ~default:Preprocess_map.default
>>= fun preprocess ->
@ -550,7 +548,8 @@ module Public_lib = struct
; sub_dir : string option
}
let public_name_field project =
let public_name_field =
Dune_project.get_exn () >>= fun project ->
map_validate (field_o "public_name" string) ~f:(function
| None -> Ok None
| Some s ->
@ -701,11 +700,11 @@ module Library = struct
; sub_systems : Sub_system_info.t Sub_system_name.Map.t
}
let v1 project =
let t =
record
(Buildable.v1 >>= fun buildable ->
(Buildable.t >>= fun buildable ->
field "name" library_name >>= fun name ->
Public_lib.public_name_field project >>= fun public ->
Public_lib.public_name_field >>= fun public ->
field_o "synopsis" string >>= fun synopsis ->
field "install_c_headers" (list string) ~default:[] >>= fun install_c_headers ->
field "ppx_runtime_libraries" (list (located string)) ~default:[] >>= fun ppx_runtime_libraries ->
@ -723,6 +722,7 @@ module Library = struct
field "self_build_stubs_archive" (option string) ~default:None >>= fun self_build_stubs_archive ->
field_b "no_dynlink" >>= fun no_dynlink ->
Sub_system_info.record_parser () >>= fun sub_systems ->
Dune_project.get_exn () >>= fun project ->
return
{ name
; public
@ -782,11 +782,11 @@ module Install_conf = struct
; package : Package.t
}
let v1 project =
let t =
record
(field "section" Install.Section.t >>= fun section ->
field "files" (list file) >>= fun files ->
Pkg.field project >>= fun package ->
Pkg.field >>= fun package ->
return
{ section
; files
@ -902,8 +902,8 @@ module Executables = struct
; buildable : Buildable.t
}
let common project names public_names ~syntax ~multi =
Buildable.v1 >>= fun buildable ->
let common names public_names ~syntax ~multi =
Buildable.t >>= fun buildable ->
(match (syntax : File_tree.Dune_file.Kind.t) with
| Dune ->
return ()
@ -974,7 +974,7 @@ module Executables = struct
(if multi then "s" else "");
return (t, None))
| files ->
Pkg.field project >>= fun package ->
Pkg.field >>= fun package ->
return (t, Some { Install_conf. section = Bin; files; package })
let public_name =
@ -982,7 +982,7 @@ module Executables = struct
| "-" -> None
| s -> Some s
let multi ~syntax project =
let multi ~syntax =
record
(field "names" (list (located string)) >>= fun names ->
map_validate (field_o "public_names" (list public_name)) ~f:(function
@ -994,13 +994,13 @@ module Executables = struct
Error "The list of public names must be of the same \
length as the list of names")
>>= fun public_names ->
common ~syntax project names public_names ~multi:true)
common ~syntax names public_names ~multi:true)
let single ~syntax project =
let single ~syntax =
record
(field "name" (located string) >>= fun name ->
field_o "public_name" string >>= fun public_name ->
common ~syntax project [name] [public_name] ~multi:false)
common ~syntax [name] [public_name] ~multi:false)
end
module Rule = struct
@ -1040,7 +1040,7 @@ module Rule = struct
; loc : Loc.t
}
let v1 =
let t =
peek raw >>= function
| List (_, (Atom _ :: _)) ->
located Action.Unexpanded.t >>| fun (loc, action) ->
@ -1085,7 +1085,7 @@ module Rule = struct
; mode : Mode.t
}
let ocamllex_v1 =
let ocamllex =
peek raw >>= function
| List (_, List (_, _) :: _) ->
record
@ -1098,7 +1098,7 @@ module Rule = struct
; mode = Standard
}
let ocamlyacc_v1 = ocamllex_v1
let ocamlyacc = ocamllex
let ocamllex_to_rule loc { modules; mode } =
let module S = String_with_vars in
@ -1149,7 +1149,7 @@ module Menhir = struct
; loc : Loc.t
}
let v1 =
let t =
record
(field_o "merge_into" string >>= fun merge_into ->
field_oslu "flags" >>= fun flags ->
@ -1181,11 +1181,11 @@ module Alias_conf = struct
else
s)
let v1 project =
let t =
record
(field "name" alias_name >>= fun name ->
field "deps" (list Dep_conf.t) ~default:[] >>= fun deps ->
field_o "package" (Pkg.t project) >>= fun package ->
field_o "package" Pkg.t >>= fun package ->
field_o "action" (located Action.Unexpanded.t) >>= fun action ->
field "locks" (list String_with_vars.t) ~default:[] >>= fun locks ->
return
@ -1202,7 +1202,7 @@ module Copy_files = struct
; glob : String_with_vars.t
}
let v1 = String_with_vars.t
let t = String_with_vars.t
end
module Documentation = struct
@ -1211,9 +1211,9 @@ module Documentation = struct
; mld_files: Ordered_set_lang.t
}
let v1 project =
let t =
record
(Pkg.field project >>= fun package ->
(Pkg.field >>= fun package ->
field "mld_files" Ordered_set_lang.t ~default:Ordered_set_lang.standard
>>= fun mld_files ->
return
@ -1289,59 +1289,59 @@ module Stanzas = struct
type constructors = (string * Stanza.t list Sexp.Of_sexp.t) list
let common project ~syntax : constructors =
let common ~syntax : constructors =
[ "library",
(Library.v1 project >>| fun x ->
(Library.t >>| fun x ->
[Library x])
; "executable" , Executables.single project ~syntax >>| execs
; "executables", Executables.multi project ~syntax >>| execs
; "executable" , Executables.single ~syntax >>| execs
; "executables", Executables.multi ~syntax >>| execs
; "rule",
(loc >>= fun loc ->
Rule.v1 >>| fun x ->
Rule.t >>| fun x ->
[Rule { x with loc }])
; "ocamllex",
(loc >>= fun loc ->
Rule.ocamllex_v1 >>| fun x ->
Rule.ocamllex >>| fun x ->
rules (Rule.ocamllex_to_rule loc x))
; "ocamlyacc",
(loc >>= fun loc ->
Rule.ocamlyacc_v1 >>| fun x ->
Rule.ocamlyacc >>| fun x ->
rules (Rule.ocamlyacc_to_rule loc x))
; "menhir",
(loc >>= fun loc ->
Menhir.v1 >>| fun x ->
Menhir.t >>| fun x ->
[Menhir { x with loc }])
; "install",
(Install_conf.v1 project >>| fun x ->
(Install_conf.t >>| fun x ->
[Install x])
; "alias",
(Alias_conf.v1 project >>| fun x ->
(Alias_conf.t >>| fun x ->
[Alias x])
; "copy_files",
(Copy_files.v1 >>| fun glob ->
(Copy_files.t >>| fun glob ->
[Copy_files {add_line_directive = false; glob}])
; "copy_files#",
(Copy_files.v1 >>| fun glob ->
(Copy_files.t >>| fun glob ->
[Copy_files {add_line_directive = true; glob}])
; "include",
(loc >>= fun loc ->
relative_file >>| fun fn ->
[Include (loc, fn)])
; "documentation",
(Documentation.v1 project >>| fun d ->
(Documentation.t >>| fun d ->
[Documentation d])
]
let dune project =
common project ~syntax:Dune @
let dune =
common ~syntax:Dune @
[ "env",
(loc >>= fun loc ->
repeat Env.rule >>| fun rules ->
[Env { loc; rules }])
]
let jbuild project =
common project ~syntax:Jbuild @
let jbuild =
common ~syntax:Jbuild @
[ "jbuild_version", (Jbuild_version.t >>| fun _ -> [])
]
@ -1354,7 +1354,7 @@ module Stanzas = struct
exception Include_loop of Path.t * (Loc.t * Path.t) list
let rec parse stanza_parser ~current_file ~include_stack sexps =
List.concat_map sexps ~f:(Sexp.Of_sexp.parse stanza_parser)
List.concat_map sexps ~f:(Sexp.Of_sexp.parse stanza_parser Univ_map.empty)
|> List.concat_map ~f:(function
| Include (loc, fn) ->
let include_stack = (loc, current_file) :: include_stack in
@ -1371,9 +1371,10 @@ module Stanzas = struct
let parse ~file ~kind (project : Dune_project.t) sexps =
let stanza_parser =
match (kind : File_tree.Dune_file.Kind.t) with
| Jbuild -> sum (jbuild project)
| Dune -> project.stanza_parser
Dune_project.set project
(match (kind : File_tree.Dune_file.Kind.t) with
| Jbuild -> sum jbuild
| Dune -> project.stanza_parser)
in
let stanzas =
try

7
src/jbuild.mli
View File

@ -2,13 +2,6 @@
open Import
module Jbuild_version : sig
type t = V1
val t : t Sexp.Of_sexp.t
val latest_stable : t
end
(** Ppx preprocessors *)
module Pp : sig
type t = private string

8
src/ordered_set_lang.ml
View File

@ -181,7 +181,7 @@ module Unexpanded = struct
match t with
| Element x -> Element x
| Union [Special (_, "include"); Element fn] ->
Include (Sexp.Of_sexp.parse String_with_vars.t fn)
Include (Sexp.Of_sexp.parse String_with_vars.t Univ_map.empty fn)
| Union [Special (loc, "include"); _]
| Special (loc, "include") ->
Loc.fail loc "(:include expects a single element (do you need to quote the filename?)"
@ -246,7 +246,8 @@ module Unexpanded = struct
let open Ast in
match t with
| Element s ->
Element (Sexp.Ast.loc s, f (Sexp.Of_sexp.parse String_with_vars.t s))
Element (Sexp.Ast.loc s,
f (Sexp.Of_sexp.parse String_with_vars.t Univ_map.empty s))
| Special (l, s) -> Special (l, s)
| Include fn ->
let sexp =
@ -262,7 +263,8 @@ module Unexpanded = struct
]
in
parse_general sexp ~f:(fun sexp ->
(Sexp.Ast.loc sexp, f (Sexp.Of_sexp.parse String_with_vars.t sexp)))
(Sexp.Ast.loc sexp,
f (Sexp.Of_sexp.parse String_with_vars.t Univ_map.empty sexp)))
| Union l -> Union (List.map l ~f:expand)
| Diff (l, r) ->
Diff (expand l, expand r)

2
src/preprocessing.ml
View File

@ -182,7 +182,7 @@ module Jbuild_driver = struct
let make name info : (Pp.t * Driver.t) Lazy.t = lazy (
let info =
Sexp.parse_string ~mode:Single ~fname:"<internal>" info
|> Sexp.Of_sexp.parse Driver.Info.parse
|> Sexp.Of_sexp.parse Driver.Info.parse Univ_map.empty
in
(Pp.of_string name,
{ info

81
src/stdune/sexp.ml
View File

@ -100,11 +100,15 @@ module Of_sexp = struct
; known : string list
}
(* The two arguments are the location of the whole list as well as
the first atom when either parsing a constructor or a field. *)
(* Arguments are:
- the location of the whole list
- the first atom when parsing a constructor or a field
- the universal map holding the user context
*)
type 'kind context =
| Values : Loc.t * string option -> values context
| Fields : Loc.t * string option -> fields context
| Values : Loc.t * string option * Univ_map.t -> values context
| Fields : Loc.t * string option * Univ_map.t -> fields context
type ('a, 'kind) parser = 'kind context -> 'kind -> 'a * 'kind
@ -123,10 +127,24 @@ module Of_sexp = struct
b ctx state
let map t ~f = t >>| f
let get_user_context : type k. k context -> Univ_map.t = function
| Values (_, _, uc) -> uc
| Fields (_, _, uc) -> uc
let get key ctx state = (Univ_map.find (get_user_context ctx) key, state)
let set : type a b k. a Univ_map.Key.t -> a -> (b, k) parser -> (b, k) parser
= fun key v t ctx state ->
match ctx with
| Values (loc, cstr, uc) ->
t (Values (loc, cstr, Univ_map.add uc key v)) state
| Fields (loc, cstr, uc) ->
t (Fields (loc, cstr, Univ_map.add uc key v)) state
let loc : type k. k context -> k -> Loc.t * k = fun ctx state ->
match ctx with
| Values (loc, _) -> (loc, state)
| Fields (loc, _) -> (loc, state)
| Values (loc, _, _) -> (loc, state)
| Fields (loc, _, _) -> (loc, state)
let eos : type k. k context -> k -> bool * k = fun ctx state ->
match ctx with
@ -146,7 +164,7 @@ module Of_sexp = struct
let result : type a k. k context -> a * k -> a =
fun ctx (v, state) ->
match ctx with
| Values (_, cstr) -> begin
| Values (_, cstr, _) -> begin
match state with
| [] -> v
| sexp :: _ ->
@ -169,11 +187,11 @@ module Of_sexp = struct
name_loc "Unknown field %s" name
end
let parse t sexp =
let ctx = Values (Ast.loc sexp, None) in
let parse t context sexp =
let ctx = Values (Ast.loc sexp, None, context) in
result ctx (t ctx [sexp])
let end_of_list (Values (loc, cstr)) =
let end_of_list (Values (loc, cstr, _)) =
match cstr with
| None ->
let loc = { loc with start = loc.stop } in
@ -188,6 +206,12 @@ module Of_sexp = struct
| sexp :: sexps -> (f sexp, sexps)
[@@inline always]
let next_with_user_context f ctx sexps =
match sexps with
| [] -> end_of_list ctx
| sexp :: sexps -> (f (get_user_context ctx) sexp, sexps)
[@@inline always]
let peek t ctx sexps =
let x, _ = t ctx sexps in
(x, sexps)
@ -201,9 +225,10 @@ module Of_sexp = struct
| List (loc, _) -> of_sexp_error loc "Atom or quoted string expected")
let enter t =
next (function
next_with_user_context (fun uc sexp ->
match sexp with
| List (loc, l) ->
let ctx = Values (loc, None) in
let ctx = Values (loc, None, uc) in
result ctx (t ctx l)
| sexp ->
of_sexp_error (Ast.loc sexp) "List expected")
@ -219,7 +244,7 @@ module Of_sexp = struct
| sexp :: rest when rest == state2 -> (* common case *)
((Ast.loc sexp, x), state2)
| [] ->
let (Values (loc, _)) = ctx in
let (Values (loc, _, _)) = ctx in
(({ loc with start = loc.stop }, x), state2)
| sexp :: rest ->
let loc = Ast.loc sexp in
@ -229,7 +254,7 @@ module Of_sexp = struct
else
match l with
| [] ->
let (Values (loc, _)) = ctx in
let (Values (loc, _, _)) = ctx in
(({ (Ast.loc sexp) with stop = loc.stop }, x), state2)
| sexp :: rest ->
search sexp rest
@ -318,10 +343,10 @@ module Of_sexp = struct
"Unknown constructor %s" name
let sum cstrs =
next (fun sexp ->
next_with_user_context (fun uc sexp ->
match sexp with
| Atom (loc, A s) ->
find_cstr cstrs loc s (Values (loc, Some s)) []
find_cstr cstrs loc s (Values (loc, Some s, uc)) []
| Quoted_string (loc, _) ->
of_sexp_error loc "Atom expected"
| List (loc, []) ->
@ -331,7 +356,7 @@ module Of_sexp = struct
| Quoted_string (loc, _) | List (loc, _) ->
of_sexp_error loc "Atom expected"
| Atom (s_loc, A s) ->
find_cstr cstrs s_loc s (Values (loc, Some s)) args)
find_cstr cstrs s_loc s (Values (loc, Some s, uc)) args)
let enum cstrs =
next (function
@ -377,7 +402,7 @@ module Of_sexp = struct
Int.compare a.Loc.start.pos_cnum b.start.pos_cnum)
with
| [] ->
let (Fields (loc, _)) = ctx in
let (Fields (loc, _, _)) = ctx in
loc
| first :: l ->
let last = List.fold_left l ~init:first ~f:(fun _ x -> x) in
@ -385,7 +410,7 @@ module Of_sexp = struct
in
of_sexp_errorf loc "%s" msg
let field_missing (Fields (loc, _)) name =
let field_missing loc name =
of_sexp_errorf loc "field %s missing" name
[@@inline never]
@ -407,21 +432,21 @@ module Of_sexp = struct
| _ -> ());
res
let field name ?default t ctx state =
let field name ?default t (Fields (loc, _, uc)) state =
match find_single state name with
| Some { values; entry; _ } ->
let ctx = Values (Ast.loc entry, Some name) in
let ctx = Values (Ast.loc entry, Some name, uc) in
let x = result ctx (t ctx values) in
(x, consume name state)
| None ->
match default with
| Some v -> (v, add_known name state)
| None -> field_missing ctx name
| None -> field_missing loc name
let field_o name t _ctx state =
let field_o name t (Fields (_, _, uc)) state =
match find_single state name with
| Some { values; entry; _ } ->
let ctx = Values (Ast.loc entry, Some name) in
let ctx = Values (Ast.loc entry, Some name, uc) in
let x = result ctx (t ctx values) in
(Some x, consume name state)
| None ->
@ -433,19 +458,19 @@ module Of_sexp = struct
| true -> return true
| _ -> bool)
let multi_field name t _ctx state =
let multi_field name t (Fields (_, _, uc)) state =
let rec loop acc field =
match field with
| None -> acc
| Some { values; prev; entry } ->
let ctx = Values (Ast.loc entry, Some name) in
let ctx = Values (Ast.loc entry, Some name, uc) in
let x = result ctx (t ctx values) in
loop (x :: acc) prev
in
let res = loop [] (Name_map.find state.unparsed name) in
(res, consume name state)
let fields t (Values (loc, cstr)) sexps =
let fields t (Values (loc, cstr, uc)) sexps =
let unparsed =
List.fold_left sexps ~init:Name_map.empty ~f:(fun acc sexp ->
match sexp with
@ -464,7 +489,7 @@ module Of_sexp = struct
of_sexp_error (Ast.loc sexp)
"S-expression of the form (<name> <values>...) expected")
in
let ctx = Fields (loc, cstr) in
let ctx = Fields (loc, cstr, uc) in
let x = result ctx (t ctx { unparsed; known = [] }) in
(x, [])

11
src/stdune/sexp.mli
View File

@ -94,8 +94,11 @@ module Of_sexp : sig
type 'a t = ('a, values) parser
type 'a fields_parser = ('a, fields) parser
(** Parse a S-expression using the following parser *)
val parse : 'a t -> ast -> 'a
(** [parse parser context sexp] parse a S-expression using the
following parser. The input consist of a single
S-expression. [context] allows to pass extra informations such as
versions to individual parsers. *)
val parse : 'a t -> Univ_map.t -> ast -> 'a
val return : 'a -> ('a, _) parser
val (>>=) : ('a, 'k) parser -> ('a -> ('b, 'k) parser) -> ('b, 'k) parser
@ -103,6 +106,10 @@ module Of_sexp : sig
val (>>>) : (unit, 'k) parser -> ('a, 'k) parser -> ('a, 'k) parser
val map : ('a, 'k) parser -> f:('a -> 'b) -> ('b, 'k) parser
(** Access to the context *)
val get : 'a Univ_map.Key.t -> ('a option, _) parser
val set : 'a Univ_map.Key.t -> 'a -> ('b, 'k) parser -> ('b, 'k) parser
(** Return the location of the list currently being parsed. *)
val loc : (Loc.t, _) parser

2
src/vfile_kind.ml
View File

@ -66,7 +66,7 @@ module Make
struct
module Of_sexp = struct
include F(Sexp.Of_sexp)
let t _ sexp = Sexp.Of_sexp.parse t sexp
let t _ sexp = Sexp.Of_sexp.parse t Univ_map.empty sexp
end
module To_sexp = struct
include F(Sexp.To_sexp)

4
src/workspace.ml
View File

@ -111,7 +111,7 @@ let t ?x ?profile:cmdline_profile sexps =
let defined_names = ref String.Set.empty in
let profiles, contexts =
List.partition_map sexps ~f:(fun sexp ->
match Sexp.Of_sexp.parse item_of_sexp sexp with
match Sexp.Of_sexp.parse item_of_sexp Univ_map.empty sexp with
| Profile (loc, p) -> Left (loc, p)
| Context c -> Right c)
in
@ -130,7 +130,7 @@ let t ?x ?profile:cmdline_profile sexps =
}
in
List.fold_left contexts ~init ~f:(fun t sexp ->
let ctx = Sexp.Of_sexp.parse (Context.t ~profile) sexp in
let ctx = Sexp.Of_sexp.parse (Context.t ~profile) Univ_map.empty sexp in
let ctx =
match x with
| None -> ctx

2
test/unit-tests/jbuild.mlt
View File

@ -8,7 +8,7 @@ open Stdune;;
(* Jbuild.Executables.Link_mode.t *)
let test s =
Sexp.Of_sexp.parse Jbuild.Executables.Link_mode.t
Sexp.Of_sexp.parse Jbuild.Executables.Link_mode.t Univ_map.empty
(Sexp.parse_string ~fname:"" ~mode:Sexp.Parser.Mode.Single s)
[%%expect{|
val test : string -> Dune.Jbuild.Executables.Link_mode.t = <fun>

4
test/unit-tests/sexp.mlt
View File

@ -24,7 +24,7 @@ val sexp : Usexp.Ast.t = ((foo 1) (foo 2))
|}]
let of_sexp = record (field "foo" int)
let x = parse of_sexp sexp
let x = parse of_sexp Univ_map.empty sexp
[%%expect{|
val of_sexp : int Stdune.Sexp.Of_sexp.t = <abstr>
Exception:
@ -33,7 +33,7 @@ Stdune__Sexp.Of_sexp.Of_sexp (<abstr>,
|}]
let of_sexp = record (multi_field "foo" int)
let x = parse of_sexp sexp
let x = parse of_sexp Univ_map.empty sexp
[%%expect{|
val of_sexp : int list Stdune.Sexp.Of_sexp.t = <abstr>
val x : int list = [1; 2]