Merge pull request #893 from diml/sexp-context

User context in S-expression parsers

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
       []
 

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

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

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:"<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

src/dune_project.ml

@@ -112,19 +112,17 @@ end = struct
 end
 
 type t =
-  { kind                  : Kind.t
+  { kind                 : Kind.t
-  ; name                  : Name.t
+  ; name                 : Name.t
-  ; root                  : Path.Local.t
+  ; root                 : Path.Local.t
-  ; version               : string option
+  ; version              : string option
-  ; packages              : Package.t Package.Name.Map.t
+  ; packages             : Package.t Package.Name.Map.t
-  ; mutable stanza_parser : Stanza.t list Sexp.Of_sexp.t
+  ; stanza_parser        : Stanza.t list Sexp.Of_sexp.t
-  ; mutable project_file  : Path.t option
+  ; 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 * Stanza.Parser.t list Sexp.Of_sexp.t
-
-  type t = Syntax.Version.t * maker
 
   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 anonymous = lazy (
-  let open Sexp.Of_sexp in
+  { kind          = Dune
-  return () >>| fun _ -> assert false
+  ; name          = Name.anonymous_root
-
+  ; packages      = Package.Name.Map.empty
-let anonymous = lazy(
+  ; root          = get_local_path Path.root
-  let t =
+  ; version       = None
-    { kind          = Dune
+  ; stanza_parser = Sexp.Of_sexp.sum (snd (Lang.latest "dune"))
-    ; name          = Name.anonymous_root
+  ; project_file  = None
-    ; 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 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
-     return t)
+       { 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
-    { kind = Jbuilder
+  ; name = default_name ~dir ~packages
-    ; name = default_name ~dir ~packages
+  ; root = get_local_path dir
-    ; root = get_local_path dir
+  ; version = None
-    ; version = None
+  ; packages
-    ; packages
+  ; stanza_parser = Sexp.Of_sexp.sum (snd (Lang.latest "dune"))
-    ; stanza_parser = fake_stanza_parser
+  ; project_file = None
-    ; project_file = None
+  }
-    }
-  in
-  t.stanza_parser <- Sexp.Of_sexp.sum (snd (Lang.latest "dune") t);
-  t
 
 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'))
-

src/dune_project.mli

@@ -31,18 +31,16 @@ end
 
 (* CR-soon diml: make this abstract *)
 type t = private
-  { kind                  : Kind.t
+  { kind                 : Kind.t
-  ; name                  : Name.t
+  ; name                 : Name.t
-  ; root                  : Path.Local.t
+  ; root                 : Path.Local.t
-  ; version               : string option
+  ; version              : string option
-  ; packages              : Package.t Package.Name.Map.t
+  ; packages             : Package.t Package.Name.Map.t
-  ; mutable stanza_parser : Stanza.t list Sexp.Of_sexp.t
+  ; stanza_parser        : Stanza.t list Sexp.Of_sexp.t
-  ; mutable project_file  : Path.t option
+  ; 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
+  val make : Syntax.Version.t -> Stanza.Parser.t list -> t
-    :  Syntax.Version.t
-    -> (project -> 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
+  val make : Syntax.Version.t -> Stanza.Parser.t list Sexp.Of_sexp.t -> t
-    :  Syntax.Version.t
-    -> (project -> 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

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 =

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 =

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
+(* This file defines the jbuild types as well as the S-expression
-   supported version of the specification.
+   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.
 *)
 
+(* 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 =
+  let common names public_names ~syntax ~multi =
-    Buildable.v1 >>= fun buildable ->
+    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
+    ; "executable" , Executables.single ~syntax >>| execs
-    ; "executables", Executables.multi  project ~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 =
+  let dune =
-    common project ~syntax:Dune @
+    common ~syntax:Dune @
     [ "env",
       (loc >>= fun loc ->
        repeat Env.rule >>| fun rules ->
        [Env { loc; rules }])
     ]
 
-  let jbuild project =
+  let jbuild =
-    common project ~syntax: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
+      Dune_project.set project
-      | Jbuild -> sum (jbuild project)
+        (match (kind : File_tree.Dune_file.Kind.t) with
-      | Dune   -> project.stanza_parser
+         | Jbuild -> sum jbuild
+         | Dune   -> project.stanza_parser)
     in
     let stanzas =
       try

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

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)

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:"<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

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
+  (* Arguments are:
-     the first atom when either parsing a constructor or a field. *)
+
+     - 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
+    | Values : Loc.t * string option * Univ_map.t -> values context
-    | Fields : Loc.t * string option -> fields 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)
+    | Values (loc, _, _) -> (loc, state)
-    | Fields (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 parse t context sexp =
-    let ctx = Values (Ast.loc sexp, None) in
+    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, [])
 

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 *)
+  (** [parse parser context sexp] parse a S-expression using the
-  val parse : 'a t -> ast -> 'a
+      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
 

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)

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

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 = <fun>

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 = <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]