Add a user context to Of_sexp.t

Signed-off-by: Jeremie Dimino <jeremie@dimino.org>

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

@@ -143,7 +143,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 ->
@@ -269,7 +269,8 @@ let load_dune_project ~dir packages =
   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 =

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

@@ -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

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]