diff --git a/src/action.ml b/src/action.ml index 3228298f..ea9f8f76 100644 --- a/src/action.ml +++ b/src/action.ml @@ -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 [] diff --git a/src/build_system.ml b/src/build_system.ml index da6e6068..9df2913f 100644 --- a/src/build_system.ml +++ b/src/build_system.ml @@ -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 diff --git a/src/config.ml b/src/config.ml index 61a87c66..ea381510 100644 --- a/src/config.ml +++ b/src/config.ml @@ -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 diff --git a/src/context.ml b/src/context.ml index 1cd6359d..3aa557ae 100644 --- a/src/context.ml +++ b/src/context.ml @@ -425,7 +425,7 @@ let create_for_opam ?root ~env ~targets ~profile ~switch ~name >>= fun s -> let vars = Usexp.parse_string ~fname:"" ~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 diff --git a/src/dune_project.ml b/src/dune_project.ml index ab28c0db..e7650c22 100644 --- a/src/dune_project.ml +++ b/src/dune_project.ml @@ -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')) - diff --git a/src/dune_project.mli b/src/dune_project.mli index 1837a150..1e990eee 100644 --- a/src/dune_project.mli +++ b/src/dune_project.mli @@ -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 [] 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 diff --git a/src/file_tree.ml b/src/file_tree.ml index d49cb736..043feb9d 100644 --- a/src/file_tree.ml +++ b/src/file_tree.ml @@ -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 = diff --git a/src/installed_dune_file.ml b/src/installed_dune_file.ml index b00d02a1..dd299263 100644 --- a/src/installed_dune_file.ml +++ b/src/installed_dune_file.ml @@ -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 = diff --git a/src/jbuild.ml b/src/jbuild.ml index 992e99e3..9ec3b527 100644 --- a/src/jbuild.ml +++ b/src/jbuild.ml @@ -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 diff --git a/src/jbuild.mli b/src/jbuild.mli index 07f423b2..2cf5cf46 100644 --- a/src/jbuild.mli +++ b/src/jbuild.mli @@ -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 diff --git a/src/ordered_set_lang.ml b/src/ordered_set_lang.ml index 7d6975bf..377adce6 100644 --- a/src/ordered_set_lang.ml +++ b/src/ordered_set_lang.ml @@ -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) diff --git a/src/preprocessing.ml b/src/preprocessing.ml index ec011d3c..1c2388e8 100644 --- a/src/preprocessing.ml +++ b/src/preprocessing.ml @@ -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:"" info - |> Sexp.Of_sexp.parse Driver.Info.parse + |> Sexp.Of_sexp.parse Driver.Info.parse Univ_map.empty in (Pp.of_string name, { info diff --git a/src/stdune/sexp.ml b/src/stdune/sexp.ml index 4df32932..f6576565 100644 --- a/src/stdune/sexp.ml +++ b/src/stdune/sexp.ml @@ -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 ( ...) 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, []) diff --git a/src/stdune/sexp.mli b/src/stdune/sexp.mli index 38ba5b76..360acdaa 100644 --- a/src/stdune/sexp.mli +++ b/src/stdune/sexp.mli @@ -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 diff --git a/src/vfile_kind.ml b/src/vfile_kind.ml index f890e68d..a8ba2a26 100644 --- a/src/vfile_kind.ml +++ b/src/vfile_kind.ml @@ -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) diff --git a/src/workspace.ml b/src/workspace.ml index e584b440..1ac468c6 100644 --- a/src/workspace.ml +++ b/src/workspace.ml @@ -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 diff --git a/test/unit-tests/jbuild.mlt b/test/unit-tests/jbuild.mlt index 05193575..cbec4627 100644 --- a/test/unit-tests/jbuild.mlt +++ b/test/unit-tests/jbuild.mlt @@ -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 = diff --git a/test/unit-tests/sexp.mlt b/test/unit-tests/sexp.mlt index 09495ad0..67e516e1 100644 --- a/test/unit-tests/sexp.mlt +++ b/test/unit-tests/sexp.mlt @@ -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 = Exception: @@ -33,7 +33,7 @@ Stdune__Sexp.Of_sexp.Of_sexp (, |}] 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 = val x : int list = [1; 2]