Refactor S-expression parsing

src/context.ml

@@ -273,7 +273,6 @@ let create_for_opam ?root ~switch ~name () =
     >>= fun s ->
     let vars =
       Sexp_lexer.single (Lexing.from_string s)
-      |> fst
       |> Sexp.Of_sexp.(string_map string)
     in
     let path =

src/gen_rules.ml

@@ -735,7 +735,7 @@ module Gen(P : Params) = struct
       Build.arr (fun () ->
         let files_contents =
           List.map2 files paths ~f:(fun fn path ->
-            (fn, Sexp_load.single (Path.to_string path) (fun x -> x)))
+            (fn, Sexp_load.single (Path.to_string path)))
           |> String_map.of_alist_exn
         in
         let set = Ordered_set_lang.Unexpanded.expand set ~files_contents in
@@ -1360,7 +1360,7 @@ module Gen(P : Params) = struct
         Sexp.To_sexp.list Dep_conf_interpret.sexp_of_t alias_conf.deps in
       let action =
         match alias_conf.action with
-        | None -> Atom "none"
+        | None -> Sexp.Atom "none"
         | Some a -> List [Atom "some" ; User_action.Unexpanded.sexp_of_t a] in
       Sexp.List [deps ; action]
       |> Sexp.to_string

src/install.mli

@@ -15,7 +15,7 @@ module Section : sig
     | Man
     | Misc
 
-  val t : Sexp.t -> t
+  val t : t Sexp.Of_sexp.t
 end
 
 module Entry : sig

src/jbuild_load.ml

@@ -9,25 +9,24 @@ type conf =
   }
 
 let load ~dir ~visible_packages ~version =
-  let version, stanzas =
+  let sexps = Sexp_load.many (Path.relative dir "jbuild" |> Path.to_string) in
-    Sexp_load.many (Path.relative dir "jbuild" |> Path.to_string)
+  let versions, sexps =
-      (fun sexps ->
+    List.partition_map sexps ~f:(function
-         let versions, sexps =
+      | List (loc, [Atom (_, ("jbuilder_version" | "Jbuilder_version")); ver]) ->
-           List.partition_map sexps ~f:(function
+        Inl (Jbuilder_version.t ver, loc)
-             | List [Atom ("jbuilder_version" | "Jbuilder_version"); ver] as sexp ->
+      | sexp -> Inr sexp)
-               Inl (Jbuilder_version.t ver, sexp)
+  in
-             | sexp -> Inr sexp)
+  let version =
-         in
+    match versions with
-         let version =
+    | [] -> version
-           match versions with
+    | [(v, _)] -> v
-           | [] -> version
+    | _ :: (_, loc) :: _ ->
-           | [(v, _)] -> v
+      Loc.fail loc "jbuilder_version specified too many times"
-           | _ :: (_, sexp) :: _ ->
+  in
-             of_sexp_error sexp "jbuilder_version specified too many times"
+  let stanzas =
-         in
+    List.filter_map sexps ~f:(Stanza.select version)
-         (version, List.filter_map sexps ~f:(Stanza.select version)))
+    |> Stanza.resolve_packages ~dir ~visible_packages
   in
-  let stanzas = Stanza.resolve_packages stanzas ~dir ~visible_packages in
   (version, stanzas)
 
 let load () =

src/jbuild_types.ml

@@ -8,10 +8,6 @@ open Sexp.Of_sexp
    [jane_street] version. When they are all the same, sexp parsers are just named [t].
 *)
 
-type sexp = Sexp.t = Atom of string | List of sexp list
-let of_sexp_error = Sexp.of_sexp_error
-let of_sexp_errorf = Sexp.of_sexp_errorf
-
 module Jbuilder_version = struct
   type t =
     | V1
@@ -73,7 +69,7 @@ module Raw_string () : sig
   type t = private string
   val to_string : t -> string
   val of_string : string -> t
-  val t : Sexp.t -> t
+  val t : t Sexp.Of_sexp.t
 end = struct
   type t = string
   let to_string t = t
@@ -130,20 +126,13 @@ module User_action = struct
       | With_stdout_to of 'a * 'a t
 
     let rec t a sexp =
-      match sexp with
+      sum
-      | List (Atom "run" :: prog :: args) -> Run (a prog, List.map args ~f:a)
+        [ cstr_rest "run" [a] a          (fun prog args -> Run (prog, args))
-      | List [ Atom "chdir"; dir; arg ] -> Chdir (a dir, t a arg)
+        ; cstr "chdir" [a; t a]          (fun dn t -> Chdir (dn, t))
-      | List [ Atom "setenv"; var; value; arg ] -> Setenv (a var, a value, t a arg)
+        ; cstr "setenv" [a; a; t a]      (fun k v t -> Setenv (k, v, t))
-      | List [ Atom "with-stdout-to"; file; arg ] -> With_stdout_to (a file, t a arg)
+        ; cstr "with-stdout-to" [a; t a] (fun fn t -> With_stdout_to (fn, t))
-      | _ ->
+        ]
-        of_sexp_error sexp "\
+        sexp
-invalid action, expected one of:
-
-  (run <prog> <args>)
-  (chdir <dir> <action>)
-  (setenv <var> <value> <action>)
-  (with-stdout-to <file> <action>)
-"
 
     let rec map t ~f =
       match t with
@@ -184,7 +173,7 @@ invalid action, expected one of:
       in
       loop String_map.empty dir [] t
 
-    let rec sexp_of_t f = function
+    let rec sexp_of_t f : _ -> Sexp.t = function
       | Run (a, xs) -> List (Atom "run" :: f a :: List.map xs ~f)
       | Chdir (a, r) -> List [Atom "chdir" ; f a ; sexp_of_t f r]
       | Setenv (k, v, r) -> List [Atom "setenv" ; f k ; f v ; sexp_of_t f r]
@@ -211,7 +200,7 @@ invalid action, expected one of:
       | Bash x -> f init x
       | Shexp x -> Mini_shexp.fold x ~init ~f
 
-    let sexp_of_t f = function
+    let sexp_of_t f : _ -> Sexp.t = function
       | Bash a -> List [Atom "bash" ; f a]
       | Shexp a -> List [Atom "shexp" ; Mini_shexp.sexp_of_t f a]
   end
@@ -296,11 +285,12 @@ module Preprocess_map = struct
     | For_all  pp  -> pp
     | Per_file map -> String_map.find_default module_name map ~default:No_preprocessing
 
-  let default = For_all (Pps { pps = Pp_set.singleton (Pp.of_string "ppx_jane"); flags = [] })
+  let default_v1 = For_all No_preprocessing
+  let default_vjs = For_all (Pps { pps = Pp_set.singleton (Pp.of_string "ppx_jane"); flags = [] })
 
   let t sexp =
     match sexp with
-    | List (Atom "per_file" :: rest) -> begin
+    | List (_, Atom (_, "per_file") :: rest) -> begin
         List.concat_map rest ~f:(fun sexp ->
           let pp, names = pair Preprocess.t module_names sexp in
           List.map (String_set.elements names) ~f:(fun name -> (name, pp)))
@@ -352,15 +342,15 @@ module Lib_dep = struct
     | Select of { result_fn : string; choices : choice list }
 
   let choice = function
-    | List l as sexp ->
+    | List (_, l) as sexp ->
       let rec loop acc = function
-        | [Atom "->"; sexp] ->
+        | [Atom (_, "->"); sexp] ->
           { lits = List.rev acc
           ; file = file sexp
           }
-        | Atom "->" :: _ | List _ :: _ | [] ->
+        | Atom (_, "->") :: _ | List _ :: _ | [] ->
           of_sexp_error sexp "(<[!]libraries>... -> <file>) expected"
-        | Atom s :: l ->
+        | Atom (_, s) :: l ->
           let len = String.length s in
           if len > 0 && s.[0] = '!' then
             let s = String.sub s ~pos:1 ~len:(len - 1) in
@@ -371,16 +361,17 @@ module Lib_dep = struct
       loop [] l
     | sexp -> of_sexp_error sexp "(<library-name> <code>) expected"
 
-  let sexp_of_choice { lits; file } =
+  let sexp_of_choice { lits; file } : Sexp.t =
-    List (List.fold_right lits ~init:[Atom "->"; Atom file] ~f:(fun lit acc ->
+    List (List.fold_right lits ~init:[Atom "->"; Atom file]
-      match lit with
+       ~f:(fun lit acc : Sexp.t list ->
-      | Pos s -> Atom s :: acc
+            match lit with
-      | Neg s -> Atom ("!" ^ s) :: acc))
+            | Pos s -> Atom s :: acc
+            | Neg s -> Atom ("!" ^ s) :: acc))
 
   let t = function
-    | Atom s ->
+    | Atom (_, s) ->
       Direct s
-    | List (Atom "select" :: m :: Atom "from" :: libs) ->
+    | List (_, Atom (_, "select") :: m :: Atom (_, "from") :: libs) ->
       Select { result_fn = file m
              ; choices   = List.map libs ~f:choice
              }
@@ -409,8 +400,8 @@ module Buildable = struct
     ; ocamlopt_flags           : Ordered_set_lang.t
     }
 
-  let common =
+  let common ~pp_default =
-    field "preprocess" Preprocess_map.t ~default:Preprocess_map.default
+    field "preprocess" Preprocess_map.t ~default:pp_default
     >>= fun preprocess ->
     field "preprocessor_deps" (list Dep_conf.t) ~default:[]
     >>= fun preprocessor_deps        ->
@@ -432,10 +423,10 @@ module Buildable = struct
       ; ocamlopt_flags
       }
 
-  let v1 = common
+  let v1 = common ~pp_default:Preprocess_map.default_v1
 
   let vjs =
-    common >>= fun t ->
+    common ~pp_default:Preprocess_map.default_vjs >>= fun t ->
     field "extra_disabled_warnings" (list int) ~default:[]
     >>= fun extra_disabled_warnings  ->
     let t =
@@ -443,11 +434,13 @@ module Buildable = struct
         let flags =
           Ordered_set_lang.append t.flags
             (Ordered_set_lang.t
-               (List [ Atom "-w"
+               (List (Loc.none,
-                     ; Atom
+                      [ Atom (Loc.none, "-w")
-                         (String.concat ~sep:""
+                      ; Atom
-                            (List.map extra_disabled_warnings ~f:(sprintf "-%d")))
+                          (Loc.none,
-                     ]))
+                           String.concat ~sep:""
+                             (List.map extra_disabled_warnings ~f:(sprintf "-%d")))
+                      ])))
         in
         { t with flags }
       else
@@ -578,7 +571,9 @@ module Library = struct
          ; c_library_flags =
              Ordered_set_lang.Unexpanded.append
                (Ordered_set_lang.Unexpanded.t
-                  (Sexp.To_sexp.(list string (List.map c_libraries ~f:((^) "-l")))))
+                  (List (Loc.none,
+                         List.map c_libraries ~f:(fun lib ->
+                             Atom (Loc.none, "-l" ^ lib)))))
                c_library_flags
          ; self_build_stubs_archive
          ; js_of_ocaml
@@ -691,14 +686,14 @@ module Provides = struct
 
   let v1 sexp =
     match sexp with
-    | Atom s ->
+    | Atom (_, s) ->
       { name = s
       ; file =
           match String.lsplit2 s ~on:':' with
           | None        -> s
           | Some (_, s) -> s
       }
-    | List [Atom s; List [Atom "file"; Atom file]] ->
+    | List (_, [Atom (_, s); List (_, [Atom (_, "file"); Atom (_, file)])]) ->
       { name = s
       ; file
       }
@@ -714,10 +709,11 @@ module Install_conf = struct
     ; dst : string option
     }
 
-  let file (sexp : Sexp.t) =
+  let file sexp =
     match sexp with
-    | Atom src                             -> { src; dst = None }
+    | Atom (_, src) -> { src; dst = None }
-    | List [Atom src; Atom "as"; Atom dst] -> { src; dst = Some dst }
+    | List (_, [Atom (_, src); Atom (_, "as"); Atom (_, dst)]) ->
+      { src; dst = Some dst }
     | _ ->
       of_sexp_error sexp
         "invalid format, <name> or (<name> as <install-as>) expected"
@@ -814,7 +810,7 @@ module Stanza = struct
       ; cstr "jbuilder_version" [Jbuilder_version.t] (fun _ -> None)
       ]
 
-  let select : Jbuilder_version.t -> Sexp.t -> t option = function
+  let select : Jbuilder_version.t -> t option Sexp.Of_sexp.t = function
     | V1  -> v1
     | Vjs -> vjs
 

src/loc.ml

@@ -30,3 +30,4 @@ let in_file fn =
   ; stop = pos
   }
 
+let none = in_file "<none>"

src/loc.mli

@@ -11,3 +11,5 @@ val fail : t -> ('a, unit, string, _) format4 -> 'a
 val fail_lex : Lexing.lexbuf -> ('a, unit, string, _) format4 -> 'a
 
 val in_file : string -> t
+
+val none : t

src/mode.mli

@@ -2,7 +2,7 @@ open! Import
 
 type t = Byte | Native
 
-val t : Sexp.t -> t
+val t : t Sexp.Of_sexp.t
 
 val all : t list
 

src/ordered_set_lang.ml

@@ -1,30 +1,30 @@
 open! Import
 
-type t = Sexp.t
+type t = Sexp.Ast.t
 
 let t t = t
 
 let eval t ~special_values =
-  let rec of_sexp : Sexp.t -> _ = function
+  let rec of_sexp : Sexp.Ast.t -> _ = function
-    | Atom "\\" -> failwith "unexpected \\"
+    | Atom (loc, "\\") -> Loc.fail loc "unexpected \\"
-    | Atom s ->
+    | Atom (loc, s) ->
       let len = String.length s in
       if len > 0 && s.[0] = ':' then
         let name = String.sub s ~pos:1 ~len:(len - 1) in
         match List.assoc name special_values with
         | l -> l
-        | exception Not_found -> Printf.ksprintf failwith "undefined symbol %s" s;
+        | exception Not_found -> Loc.fail loc "undefined symbol %s" s;
       else
         [s]
-    | List sexps -> of_sexps [] sexps
+    | List (_, sexps) -> of_sexps [] sexps
   and of_sexps acc = function
-    | Atom "\\" :: sexps -> of_sexps_negative acc sexps
+    | Atom (_, "\\") :: sexps -> of_sexps_negative acc sexps
     | elt :: sexps ->
       let elts = of_sexp elt in
       of_sexps (List.rev_append elts acc) sexps
     | [] -> List.rev acc
   and of_sexps_negative acc = function
-    | Atom "\\" :: sexps -> of_sexps_negative acc sexps
+    | Atom (_, "\\") :: sexps -> of_sexps_negative acc sexps
     | elt :: sexps ->
       let elts = of_sexp elt in
       let acc = List.filter acc ~f:(fun acc_elt -> not (List.mem acc_elt ~set:elts)) in
@@ -34,7 +34,7 @@ let eval t ~special_values =
   of_sexp t
 
 let is_standard : t -> bool = function
-  | Atom ":standard" -> true
+  | Atom (_, ":standard") -> true
   | _ -> false
 
 let eval_with_standard t ~standard =
@@ -45,17 +45,17 @@ let eval_with_standard t ~standard =
 
 let rec map (t : t) ~f =
   match t with
-  | Atom s ->
+  | Atom (loc, s) ->
     let len = String.length s in
     if len > 0 && s.[0] = ':' then
       t
     else
-      Atom (f s)
+      Atom (loc, f s)
-  | List l -> List (List.map l ~f:(map ~f))
+  | List (loc, l) -> List (loc, List.map l ~f:(map ~f))
 
-let standard : t = Atom ":standard"
+let standard : t = Atom (Loc.none, ":standard")
 
-let append a b = Sexp.List [a; b]
+let append a b : t = List (Loc.none, [a; b])
 
 module Unexpanded = struct
   type nonrec t = t
@@ -67,16 +67,16 @@ module Unexpanded = struct
   let files t =
     let rec loop acc : t -> _ = function
       | Atom _ -> acc
-      | List [Atom ":include"; Atom fn] -> String_set.add fn acc
+      | List (_, [Atom (_, ":include"); Atom (_, fn)]) -> String_set.add fn acc
-      | List l -> List.fold_left l ~init:acc ~f:loop
+      | List (_, l) -> List.fold_left l ~init:acc ~f:loop
     in
     loop String_set.empty t
 
   let rec expand (t : t) ~files_contents =
     match t with
     | Atom _ -> t
-    | List [Atom ":include"; Atom fn] ->
+    | List (_, [Atom (_, ":include"); Atom (_, fn)]) ->
       String_map.find_exn fn files_contents ~string_of_key:(sprintf "%S")
         ~desc:(fun _ -> "<filename to s-expression>")
-    | List l -> List (List.map l ~f:(expand ~files_contents))
+    | List (loc, l) -> List (loc, List.map l ~f:(expand ~files_contents))
 end

src/ordered_set_lang.mli

@@ -4,7 +4,7 @@
 open Import
 
 type t
-val t : Sexp.t -> t
+val t : t Sexp.Of_sexp.t
 
 val eval_with_standard : t -> standard:string list -> string list
 val standard : t
@@ -17,7 +17,7 @@ val map : t -> f:(string -> string) -> t
 module Unexpanded : sig
   type expanded = t
   type t
-  val t : Sexp.t -> t
+  val t : t Sexp.Of_sexp.t
   val standard : t
 
   val append : t -> t -> t
@@ -28,5 +28,5 @@ module Unexpanded : sig
   (** Expand [t] using with the given file contents. [file_contents] is a map from
       filenames to their parsed contents. Every [(:include fn)] in [t] is replaced by
       [Map.find files_contents fn]. *)
-  val expand : t -> files_contents:Sexp.t String_map.t -> expanded
+  val expand : t -> files_contents:Sexp.Ast.t String_map.t -> expanded
 end with type expanded := t

src/sexp.ml

@@ -4,46 +4,16 @@ type t =
   | Atom of string
   | List of t list
 
-type sexp = t
+module Ast = struct
-
-module Locs = struct
   type t =
-    | Atom of Loc.t
+    | Atom of Loc.t * string
     | List of Loc.t * t list
 
   let loc = function
-    | Atom loc -> loc
+    | Atom (loc, _) -> loc
     | List (loc, _) -> loc
 end
 
-let locate_in_list ts ~sub ~locs =
-  let rec loop ts locs =
-    match ts, locs with
-    | [], _ -> None
-    | _, [] -> assert false
-    | t::ts, loc::locs ->
-      if t == sub then
-        Some (Locs.loc loc)
-      else
-        match t, loc with
-        | Atom _, _ -> loop ts locs
-        | List inner_ts, List (_, inner_locs) -> begin
-            match loop inner_ts inner_locs with
-            | None -> loop ts locs
-            | Some _ as res -> res
-          end
-        | _ -> assert false
-  in
-  loop ts locs
-
-let locate t ~sub ~locs =
-  locate_in_list [t] ~sub ~locs:[locs]
-
-exception Of_sexp_error of t * string
-
-let of_sexp_error t msg = raise (Of_sexp_error (t, msg))
-let of_sexp_errorf t fmt = Printf.ksprintf (of_sexp_error t) fmt
-
 let must_escape str =
   let len = String.length str in
   len = 0 ||
@@ -97,14 +67,21 @@ module To_sexp = struct
 end
 
 module Of_sexp = struct
-  type nonrec 'a t = t -> 'a
+  type ast = Ast.t =
+    | Atom of Loc.t * string
+    | List of Loc.t * ast list
+
+  type 'a t = ast -> 'a
+
+  let of_sexp_error sexp str = raise (Loc.Error (Ast.loc sexp, str))
+  let of_sexp_errorf sexp fmt = ksprintf (of_sexp_error sexp) fmt
 
   let unit = function
-    | List [] -> ()
+    | List (_, []) -> ()
     | sexp -> of_sexp_error sexp "() expected"
 
   let string = function
-    | Atom s -> s
+    | Atom (_, s) -> s
     | List _ as sexp -> of_sexp_error sexp "Atom expected"
 
   let int sexp =
@@ -121,16 +98,16 @@ module Of_sexp = struct
     | _ -> of_sexp_error sexp "'true' or 'false' expected"
 
   let pair fa fb = function
-    | List [a; b] -> (fa a, fb b)
+    | List (_, [a; b]) -> (fa a, fb b)
     | sexp -> of_sexp_error sexp "S-expression of the form (_ _) expected"
 
   let list f = function
     | Atom _ as sexp -> of_sexp_error sexp "List expected"
-    | List l -> List.map l ~f
+    | List (_, l) -> List.map l ~f
 
   let option f = function
-    | List [] -> None
+    | List (_, []) -> None
-    | List [x] -> Some (f x)
+    | List (_, [x]) -> Some (f x)
     | sexp -> of_sexp_error sexp "S-expression of the form () or (_) expected"
 
   let string_set sexp = String_set.of_list (list string sexp)
@@ -141,8 +118,8 @@ module Of_sexp = struct
       of_sexp_error sexp (sprintf "key %S present multiple times" key)
 
   type unparsed_field =
-    { value : sexp option
+    { value : Ast.t option
-    ; entry : sexp
+    ; entry : Ast.t
     }
 
   module Name_map = Map.Make(struct
@@ -158,7 +135,7 @@ module Of_sexp = struct
     end)
 
   type record_parser_state =
-    { record   : sexp
+    { loc      : Loc.t
     ; unparsed : unparsed_field Name_map.t
     ; known    : string list
     }
@@ -195,19 +172,19 @@ module Of_sexp = struct
     | Some { value = Some value; _ } ->
       (value_of_sexp value, consume name state)
     | Some { value = None; _ } ->
-      of_sexp_error  state.record (Printf.sprintf "field %s needs a value" name)
+      Loc.fail state.loc "field %s needs a value" name
     | None ->
       match default with
       | Some v -> (v, add_known name state)
       | None ->
-        of_sexp_error state.record (Printf.sprintf "field %s missing" name)
+        Loc.fail state.loc "field %s missing" name
 
   let field_o name value_of_sexp state =
     match Name_map.find name state.unparsed with
     | Some { value = Some value; _ } ->
       (Some (value_of_sexp value), consume name state)
     | Some { value = None; _ } ->
-      of_sexp_error state.record (Printf.sprintf "field %s needs a value" name)
+      Loc.fail state.loc "field %s needs a value" name
     | None -> (None, add_known name state)
 
   let field_b name state =
@@ -222,15 +199,15 @@ module Of_sexp = struct
   let make_record_parser_state sexp =
     match sexp with
     | Atom _ -> of_sexp_error sexp "List expected"
-    | List sexps ->
+    | List (loc, sexps) ->
       let unparsed =
         List.fold_left sexps ~init:Name_map.empty ~f:(fun acc sexp ->
           match sexp with
-          | List [Atom name] ->
+          | List (_, [Atom (_, name)]) ->
             Name_map.add acc ~key:name ~data:{ value = None; entry = sexp }
-          | List [name_sexp; value] -> begin
+          | List (_, [name_sexp; value]) -> begin
               match name_sexp with
-              | Atom name ->
+              | Atom (_, name) ->
                 Name_map.add acc ~key:name ~data:{ value = Some value; entry = sexp }
               | List _ ->
                 of_sexp_error name_sexp "Atom expected"
@@ -238,7 +215,7 @@ module Of_sexp = struct
           | _ ->
             of_sexp_error sexp "S-expression of the form (_ _) expected")
       in
-      { record = sexp
+      { loc    = loc
       ; known  = []
       ; unparsed
       }
@@ -252,38 +229,48 @@ module Of_sexp = struct
       let name, { entry; _ } = Name_map.choose state.unparsed in
       let name_sexp =
         match entry with
-        | List (s :: _) -> s
+        | List (_, s :: _) -> s
         | _ -> assert false
       in
       of_sexp_errorf name_sexp
         "Unknown field %s%s" name (hint name state.known)
 
+  type ('a, 'b) rest =
+    | No_rest : ('a, 'a) rest
+    | Many    : 'a t -> ('a list -> 'b, 'b) rest
+
   module Constructor_args_spec = struct
     type 'a conv = 'a t
     type ('a, 'b) t =
       | [] : ('a, 'a) t
       | ( :: ) : 'a conv * ('b, 'c) t -> ('a -> 'b, 'c) t
 
-    let rec convert : type a b. (a, b) t -> sexp -> sexp list -> a -> b
+    let rec convert : type a b c. (a, b) t -> (b, c) rest -> Ast.t -> Ast.t list -> a -> c
-      = fun t sexp sexps f ->
+      = fun t rest sexp sexps f ->
-        match t, sexps with
+        match t, rest, sexps with
-        | [], [] -> f
+        | [], No_rest, [] -> f
-        | _ :: _, [] -> of_sexp_error sexp "not enough arguments"
+        | [], Many _ , [] -> f []
-        | [], _ :: _ -> of_sexp_error sexp "too many arguments"
+        | _ :: _, _, [] -> of_sexp_error sexp "not enough arguments"
-        | conv :: t, s :: sexps ->
+        | [], No_rest, _ :: _ -> of_sexp_error sexp "too many arguments"
-          convert t sexp sexps (f (conv s))
+        | [], Many conv, l -> f (List.map l ~f:conv)
+        | conv :: t, _, s :: sexps ->
+          convert t rest sexp sexps (f (conv s))
   end
 
   module Constructor_spec = struct
     type 'a t =
         T : { name : string
             ; args : ('a, 'b) Constructor_args_spec.t
+            ; rest : ('b, 'c) rest
             ; make : 'a
-            } -> 'b t
+            } -> 'c t
   end
 
+  let cstr_rest name args rest make =
+    Constructor_spec.T { name; args; make; rest = Many rest }
+
   let cstr name args make =
-    Constructor_spec.T { name; args; make }
+    Constructor_spec.T { name; args; make; rest = No_rest }
 
   let equal_cstr_name a b =
     let alen = String.length a and blen = String.length b in
@@ -321,22 +308,22 @@ module Of_sexp = struct
 
   let sum cstrs sexp =
     match sexp with
-    | Atom s -> begin
+    | Atom (_, s) -> begin
         let (Constructor_spec.T c) = find_cstr cstrs sexp s in
-        Constructor_args_spec.convert c.args sexp [] c.make
+        Constructor_args_spec.convert c.args c.rest sexp [] c.make
       end
-    | List [] -> of_sexp_error sexp "non-empty list expected"
+    | List (_, []) -> of_sexp_error sexp "non-empty list expected"
-    | List (name_sexp :: args) ->
+    | List (_, name_sexp :: args) ->
       match name_sexp with
       | List _ -> of_sexp_error name_sexp "Atom expected"
-      | Atom s ->
+      | Atom (_, s) ->
         let (Constructor_spec.T c) = find_cstr cstrs sexp s in
-        Constructor_args_spec.convert c.args sexp args c.make
+        Constructor_args_spec.convert c.args c.rest sexp args c.make
 
   let enum cstrs sexp =
     match sexp with
     | List _ -> of_sexp_error sexp "Atom expected"
-    | Atom s ->
+    | Atom (_, s) ->
       match
         List.find cstrs ~f:(fun (name, _) ->
           equal_cstr_name name s)
@@ -350,25 +337,3 @@ module Of_sexp = struct
              (List.map cstrs ~f:(fun (name, _) ->
                 String.uncapitalize_ascii name)))
 end
-(*
-module Both = struct
-  type sexp = t
-  type 'a t =
-    { of_sexp : sexp -> 'a
-    ; to_sexp : 'a -> sexp
-    }
-
-  module A = Of_sexp
-  module B = To_Sexp
-
-  let string = { of_sexp = A.string; to_sexp = B.string }
-  let int = { of_sexp = A.int; to_sexp = B.int }
-  let pair a b = { of_sexp = A.pair a.of_sexp b.of_sexp
-                 ; to_sexp =
-  let list f l = List (List.map l ~f)
-  let string_set set = list string (String_set.elements set)
-  let string_map f map = list (pair string f) (String_map.bindings map)
-end
-  functor (C : Sexp.Combinators) -> struct
-    open C
-   let t = string int int *)

src/sexp.mli

@@ -4,23 +4,15 @@ type t =
   | Atom of string
   | List of t list
 
-exception Of_sexp_error of t * string
+module Ast : sig
-
-val of_sexp_error : t -> string -> _
-val of_sexp_errorf : t -> ('a, unit, string, 'b) format4 -> 'a
-
-val code_error : string -> (string * t) list -> _
-
-module Locs : sig
   type t =
-    | Atom of Loc.t
+    | Atom of Loc.t * string
     | List of Loc.t * t list
 
   val loc : t -> Loc.t
 end
 
-val locate         : t      -> sub:t -> locs:Locs.t      -> Loc.t option
+val code_error : string -> (string * t) list -> _
-val locate_in_list : t list -> sub:t -> locs:Locs.t list -> Loc.t option
 
 val to_string : t -> string
 
@@ -40,7 +32,14 @@ end
 module To_sexp : Combinators with type 'a t = 'a -> t
 
 module Of_sexp : sig
-  include Combinators with type 'a t = t -> 'a
+  type ast = Ast.t =
+    | Atom of Loc.t * string
+    | List of Loc.t * ast list
+
+  include Combinators with type 'a t = Ast.t -> 'a
+
+  val of_sexp_error  : Ast.t -> string -> _
+  val of_sexp_errorf : Ast.t -> ('a, unit, string, 'b) format4 -> 'a
 
   (* Record parsing monad *)
   type 'a record_parser
@@ -67,6 +66,12 @@ module Of_sexp : sig
   end with type 'a conv := 'a t
 
   val cstr : string -> ('a, 'b) Constructor_args_spec.t -> 'a -> 'b Constructor_spec.t
+  val cstr_rest
+    :  string
+    -> ('a, 'b list -> 'c) Constructor_args_spec.t
+    -> 'b t
+    -> 'a
+    -> 'c Constructor_spec.t
 
   val sum
     :  'a Constructor_spec.t list

src/sexp_lexer.mli

@@ -1,2 +1,2 @@
-val single : Lexing.lexbuf ->  Sexp.t * Sexp.Locs.t
+val single : Lexing.lexbuf -> Sexp.Ast.t
-val many   : Lexing.lexbuf -> (Sexp.t * Sexp.Locs.t) list
+val many   : Lexing.lexbuf -> Sexp.Ast.t list

src/sexp_lexer.mll

@@ -2,32 +2,30 @@
 type stack =
   | Empty
   | Open of Lexing.position * stack
-  | Sexp of Sexp.t * Sexp.Locs.t * stack
+  | Sexp of Sexp.Ast.t * stack
 
 let error = Loc.fail_lex
 
 let make_list =
-  let rec loop lexbuf acc acc_locs = function
+  let rec loop lexbuf acc = function
     | Empty ->
       error lexbuf "right parenthesis without matching left parenthesis"
     | Open (start, stack) ->
-      Sexp (List acc,
+      Sexp (List ({ start; stop = Lexing.lexeme_end_p lexbuf }, acc),
-            List ({ start; stop = Lexing.lexeme_end_p lexbuf }, acc_locs),
             stack)
-    | Sexp (sexp, locs, stack) -> loop lexbuf (sexp :: acc) (locs :: acc_locs) stack
+    | Sexp (sexp, stack) -> loop lexbuf (sexp :: acc) stack
   in
-  fun lexbuf stack -> loop lexbuf [] [] stack
+  fun lexbuf stack -> loop lexbuf [] stack
 
 let new_sexp loop stack lexbuf =
   match stack with
-  | Sexp (sexp, locs, Empty) -> Some (sexp, locs)
+  | Sexp (sexp, Empty) -> Some sexp
   | _ -> loop stack lexbuf
 
-let atom_loc lexbuf : Sexp.Locs.t =
+let atom_loc lexbuf : Loc.t =
-  Atom
+  { start = Lexing.lexeme_start_p lexbuf
-    { start = Lexing.lexeme_start_p lexbuf
+  ; stop  = Lexing.lexeme_end_p   lexbuf
-    ; stop  = Lexing.lexeme_end_p   lexbuf
+  }
-    }
 
 let char_for_backslash = function
   | 'n' -> '\010'
@@ -81,7 +79,7 @@ rule main stack = parse
   | "#|"
     { block_comment 0 stack lexbuf }
   | unquoted* as s
-    { new_sexp main (Sexp (Atom s, atom_loc lexbuf, stack)) lexbuf }
+    { new_sexp main (Sexp (Atom (atom_loc lexbuf, s), stack)) lexbuf }
   | eof
     { match stack with
       | Empty -> None
@@ -105,8 +103,8 @@ and block_comment depth stack = parse
 and scan_string buf start stack = parse
   | '"'
       { new_sexp main
-          (Sexp (Atom (Buffer.contents buf),
+          (Sexp (Atom ({ start; stop = Lexing.lexeme_end_p lexbuf },
-                 Atom { start; stop = Lexing.lexeme_end_p lexbuf },
+                       Buffer.contents buf),
                  stack))
           lexbuf
       }

src/sexp_load.ml

@@ -1,30 +1,7 @@
 open Import
 
-let single fn f =
+let single fn =
-  let sexp, locs =
+  with_lexbuf_from_file fn ~f:Sexp_lexer.single
-    with_lexbuf_from_file fn ~f:Sexp_lexer.single
-  in
-  try
-    f sexp
-  with Sexp.Of_sexp_error (sub, msg) ->
-    let loc =
-      match Sexp.locate sexp ~sub ~locs with
-      | None -> Loc.in_file fn
-      | Some loc -> loc
-    in
-    Loc.fail loc "%s" msg
 
-let many fn f =
+let many fn =
-  let sexps, locs =
+  with_lexbuf_from_file fn ~f:Sexp_lexer.many
-    with_lexbuf_from_file fn ~f:Sexp_lexer.many
-    |> List.split
-  in
-  try
-    f sexps
-  with Sexp.Of_sexp_error (sub, msg) ->
-    let loc =
-      match Sexp.locate_in_list sexps ~sub ~locs with
-      | None -> Loc.in_file fn
-      | Some loc -> loc
-    in
-    Loc.fail loc "%s" msg

src/sexp_load.mli

@@ -1,4 +1,4 @@
 open! Import
 
-val single : string -> (Sexp.t -> 'a) -> 'a
+val single : string -> Sexp.Ast.t
-val many   : string -> (Sexp.t list -> 'a) -> 'a
+val many   : string -> Sexp.Ast.t list

src/string_with_vars.ml

@@ -91,7 +91,7 @@ let expand t ~f =
 
 module type Container = sig
   type 'a t
-  val t : (Sexp.t -> 'a) -> Sexp.t -> 'a t
+  val t : 'a Sexp.Of_sexp.t -> 'a t Sexp.Of_sexp.t
   val sexp_of_t : ('a -> Sexp.t) -> 'a t -> Sexp.t
 
   val map : 'a t -> f:('a -> 'b) -> 'b t

src/string_with_vars.mli

@@ -6,7 +6,7 @@
 open Import
 
 type t
-val t : Sexp.t -> t
+val t : t Sexp.Of_sexp.t
 val sexp_of_t : t -> Sexp.t
 
 val of_string : string -> t
@@ -19,7 +19,7 @@ val expand : t -> f:(string -> string option) -> string
 
 module type Container = sig
   type 'a t
-  val t : (Sexp.t -> 'a) -> Sexp.t -> 'a t
+  val t : 'a Sexp.Of_sexp.t -> 'a t Sexp.Of_sexp.t
   val sexp_of_t : ('a -> Sexp.t) -> 'a t -> Sexp.t
 
   val map : 'a t -> f:('a -> 'b) -> 'b t
@@ -28,7 +28,7 @@ end
 
 module Lift(M : Container) : sig
   type nonrec t = t M.t
-  val t : Sexp.t -> t
+  val t : t Sexp.Of_sexp.t
 
   val sexp_of_t : t -> Sexp.t
 

src/vfile_kind.ml

@@ -45,7 +45,7 @@ let eq (type a) (type b)
 module Make_full
     (T : sig type t end)
     (To_sexp : sig val t : T.t -> Sexp.t end)
-    (Of_sexp : sig val t : Sexp.t -> T.t end)
+    (Of_sexp : sig val t : Sexp.Ast.t -> T.t end)
   : S with type t = T.t =
 struct
   type t = T.t
@@ -59,10 +59,7 @@ struct
     close_out oc
 
   let load ~filename =
-    let sexp, _locs =
+    Of_sexp.t (Sexp_load.single filename)
-      with_lexbuf_from_file filename ~f:Sexp_lexer.single
-    in
-    Of_sexp.t sexp
 end
 
 

src/vfile_kind.mli

@@ -27,5 +27,5 @@ module Make
 module Make_full
     (T : sig type t end)
     (To_sexp : sig val t : T.t -> Sexp.t end)
-    (Of_sexp : sig val t : Sexp.t -> T.t end)
+    (Of_sexp : sig val t : Sexp.Ast.t -> T.t end)
   : S with type t = T.t

src/workspace.ml

@@ -1,10 +1,6 @@
 open Import
 open Sexp.Of_sexp
 
-type sexp = Sexp.t = Atom of string | List of sexp list
-let of_sexp_error = Sexp.of_sexp_error
-let of_sexp_errorf = Sexp.of_sexp_errorf
-
 module Context = struct
   module Opam = struct
     type t =
@@ -27,7 +23,7 @@ module Context = struct
   type t = Default | Opam of Opam.t
 
   let t = function
-    | Atom "default" -> Default
+    | Atom (_, "default") -> Default
     | sexp -> Opam (Opam.t sexp)
 
   let name = function
@@ -55,4 +51,4 @@ let t sexps =
     ctx :: acc)
   |> List.rev
 
-let load fn = Sexp_load.many fn t
+let load fn = t (Sexp_load.many fn)

src/workspace.mli

@@ -0,0 +1,19 @@
+(** Workspaces definitions *)
+
+open! Import
+
+module Context : sig
+  module Opam : sig
+    type t =
+      { name   : string
+      ; switch : string
+      ; root   : string option
+      }
+  end
+
+  type t = Default | Opam of Opam.t
+end
+
+type t = Context.t list
+
+val load : string -> t