From 3c74bf07e8c6d5a9ffa1d6353a9f4b6235a6dd8e Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?J=C3=A9r=C3=A9mie=20Dimino?= <jeremie@dimino.org>
Date: Thu, 14 Jun 2018 08:51:27 +0100
Subject: [PATCH] Use the same monad to parse all list of S-expressions (#882)

Signed-off-by: Jeremie Dimino <jeremie@dimino.org>
---
 src/action.ml              |  98 ++++++++-----
 src/dune_project.ml        |  54 ++++---
 src/dune_project.mli       |  12 +-
 src/file_tree.ml           |   2 +-
 src/inline_tests.ml        |   4 +-
 src/installed_dune_file.ml |   6 +-
 src/jbuild.ml              | 105 ++++++++------
 src/preprocessing.ml       |   2 +-
 src/stanza.ml              |   2 +-
 src/stanza.mli             |   2 +-
 src/stdune/path.ml         |   9 +-
 src/stdune/sexp.ml         | 279 ++++++++++++++++---------------------
 src/stdune/sexp.mli        | 116 ++++++++-------
 src/workspace.ml           |  19 +--
 14 files changed, 358 insertions(+), 352 deletions(-)

diff --git a/src/action.ml b/src/action.ml
index 63a0e0b8..a38dae02 100644
--- a/src/action.ml
+++ b/src/action.ml
@@ -24,37 +24,73 @@ struct
   let rec t sexp =
     let path = Path.t and string = String.t in
     sum
-      [ cstr "run" (Program.t @> rest string) (fun prog args -> Run (prog, args))
-      ; cstr "chdir"    (path @> t @> nil)        (fun dn t -> Chdir (dn, t))
-      ; cstr "setenv"   (string @> string @> t @> nil)   (fun k v t -> Setenv (k, v, t))
-      ; cstr "with-stdout-to"  (path @> t @> nil) (fun fn t -> Redirect (Stdout, fn, t))
-      ; cstr "with-stderr-to"  (path @> t @> nil) (fun fn t -> Redirect (Stderr, fn, t))
-      ; cstr "with-outputs-to" (path @> t @> nil) (fun fn t -> Redirect (Outputs, fn, t))
-      ; cstr "ignore-stdout"   (t @> nil)      (fun t -> Ignore (Stdout, t))
-      ; cstr "ignore-stderr"   (t @> nil)      (fun t -> Ignore (Stderr, t))
-      ; cstr "ignore-outputs"  (t @> nil)      (fun t -> Ignore (Outputs, t))
-      ; cstr "progn"           (rest t)        (fun l -> Progn l)
-      ; cstr "echo"      (string @> rest string) (fun x xs -> Echo (x::xs))
-      ; cstr "cat"            (path @> nil)         (fun x -> Cat x)
-      ; cstr "copy" (path @> path @> nil)              (fun src dst -> Copy (src, dst))
-      (*
-         (* We don't expose symlink to the user yet since this might complicate things *)
-         ; cstr "symlink" (a @> a @> nil) (fun src dst -> Symlink (dst, Cat src))
-      *)
-      ; cstr "copy#" (path @> path @> nil) (fun src dst ->
-          Copy_and_add_line_directive (src, dst))
-      ; cstr "copy-and-add-line-directive" (cstr_loc (path @> path @> nil)) (fun loc src dst ->
-          Loc.warn loc "copy-and-add-line-directive is deprecated, use copy# instead";
-          Copy_and_add_line_directive (src, dst))
-      ; cstr "copy#" (path @> path @> nil) (fun src dst ->
-          Copy_and_add_line_directive (src, dst))
-      ; cstr "system" (string @> nil) (fun cmd -> System cmd)
-      ; cstr "bash"   (string @> nil) (fun cmd -> Bash   cmd)
-      ; cstr "write-file" (path @> string @> nil) (fun fn s -> Write_file (fn, s))
-      ; cstr "diff" (path @> path @> nil)
-          (fun file1 file2 -> Diff { optional = false; file1; file2 })
-      ; cstr "diff?" (path @> path @> nil)
-          (fun file1 file2 -> Diff { optional = true ; file1; file2 })
+      [ "run",
+        (next Program.t >>= fun prog ->
+         rest string    >>| fun args ->
+         Run (prog, args))
+      ; "chdir",
+        (next path >>= fun dn ->
+         next t    >>| fun t ->
+         Chdir (dn, t))
+      ; "setenv",
+        (next string >>= fun k ->
+         next string >>= fun v ->
+         next t      >>| fun t ->
+         Setenv (k, v, t))
+      ; "with-stdout-to",
+        (next path >>= fun fn ->
+         next t    >>| fun t ->
+         Redirect (Stdout, fn, t))
+      ; "with-stderr-to",
+        (next path >>= fun fn ->
+         next t    >>| fun t  ->
+         Redirect (Stderr, fn, t))
+      ; "with-outputs-to",
+        (next path >>= fun fn ->
+         next t    >>| fun t  ->
+         Redirect (Outputs, fn, t))
+      ; "ignore-stdout",
+        (next t >>| fun t -> Ignore (Stdout, t))
+      ; "ignore-stderr",
+        (next t >>| fun t -> Ignore (Stderr, t))
+      ; "ignore-outputs",
+        (next t >>| fun t -> Ignore (Outputs, t))
+      ; "progn",
+        (rest t >>| fun l -> Progn l)
+      ; "echo",
+        (next string >>= fun x ->
+         rest string >>| fun xs ->
+         Echo (x :: xs))
+      ; "cat",
+        (next path >>| fun x -> Cat x)
+      ; "copy",
+        (next path >>= fun src ->
+         next path >>| fun dst ->
+         Copy (src, dst))
+      ; "copy#",
+        (next path >>= fun src ->
+         next path >>| fun dst ->
+         Copy_and_add_line_directive (src, dst))
+      ; "copy-and-add-line-directive",
+        (next path >>= fun src ->
+         next path >>| fun dst ->
+         Copy_and_add_line_directive (src, dst))
+      ; "system",
+        (next string >>| fun cmd -> System cmd)
+      ; "bash",
+        (next string >>| fun cmd -> Bash cmd)
+      ; "write-file",
+        (next path >>= fun fn ->
+         next string >>| fun s ->
+         Write_file (fn, s))
+      ; "diff",
+        (next path >>= fun file1 ->
+         next path >>| fun file2 ->
+         Diff { optional = false; file1; file2 })
+      ; "diff?",
+        (next path >>= fun file1 ->
+         next path >>| fun file2 ->
+         Diff { optional = true; file1; file2 })
       ]
       sexp
 
diff --git a/src/dune_project.ml b/src/dune_project.ml
index 49158c5f..066f7497 100644
--- a/src/dune_project.ml
+++ b/src/dune_project.ml
@@ -159,14 +159,11 @@ module Lang = struct
 end
 
 module Extension = struct
-  type maker =
-      T : ('a, Stanza.Parser.t list) Sexp.Of_sexp.Constructor_args_spec.t *
-          (project -> 'a)
-      -> maker
+  type maker = project -> Stanza.Parser.t list Sexp.Of_sexp.cstr_parser
 
   type t = Syntax.Version.t * maker
 
-  let make ver args_spec f = (ver, T (args_spec, f))
+  let make ver f = (ver, f)
 
   let extensions = Hashtbl.create 32
 
@@ -176,22 +173,13 @@ module Extension = struct
         [ "name", Sexp.To_sexp.string name ];
     Hashtbl.add extensions name (Syntax.Versioned_parser.make versions)
 
-  let parse project entries =
-    match String.Map.of_list entries with
-    | Error (name, _, (loc, _, _)) ->
-      Loc.fail loc "Exntesion %S specified for the second time." name
-    | Ok _ ->
-      List.concat_map entries ~f:(fun (name, (loc, (ver_loc, ver), args)) ->
-        match Hashtbl.find extensions name with
-        | None ->
-          Loc.fail loc "Unknown extension %S.%s" name
-            (hint name (Hashtbl.keys extensions))
-        | Some versions ->
-          let (T (spec, f)) =
-            Syntax.Versioned_parser.find_exn versions
-              ~loc:ver_loc ~data_version:ver
-          in
-          Sexp.Of_sexp.Constructor_args_spec.parse spec args (f project))
+  let lookup (name_loc, name) (ver_loc, ver) =
+    match Hashtbl.find extensions name with
+    | None ->
+      Loc.fail name_loc "Unknown extension %S.%s" name
+        (hint name (Hashtbl.keys extensions))
+    | Some versions ->
+      Syntax.Versioned_parser.find_exn versions ~loc:ver_loc ~data_version:ver
 end
 
 let filename = "dune-project"
@@ -243,13 +231,6 @@ let parse ~dir ~lang_stanzas ~packages ~file =
   record
     (name ~dir ~packages >>= fun name ->
      field_o "version" string >>= fun version ->
-     dup_field_multi "using"
-       (located string
-        @> located Syntax.Version.t
-        @> cstr_loc (rest raw))
-       (fun (loc, name) ver args_loc args ->
-          (name, (loc, ver, Sexp.Ast.List (args_loc, args))))
-     >>= fun extensions ->
      let t =
        { kind = Dune
        ; name
@@ -260,8 +241,21 @@ let parse ~dir ~lang_stanzas ~packages ~file =
        ; project_file  = Some file
        }
      in
-     let extenstions_stanzas = Extension.parse t extensions in
-     t.stanza_parser <- Sexp.Of_sexp.sum (lang_stanzas t @ extenstions_stanzas);
+     dup_field_multi "using"
+       (list_loc >>= fun loc ->
+        next (located string) >>= fun name ->
+        next (located Syntax.Version.t) >>= fun ver ->
+        Extension.lookup name ver t >>= fun stanzas ->
+        return (snd name, (loc, stanzas)))
+     >>= fun extensions ->
+     let extensions_stanzas =
+       match String.Map.of_list extensions with
+       | Error (name, _, (loc, _)) ->
+         Loc.fail loc "Extension %S specified for the second time." name
+       | Ok _ ->
+         List.concat_map extensions ~f:(fun (_, (_, x)) -> x)
+     in
+     t.stanza_parser <- Sexp.Of_sexp.sum (lang_stanzas t @ extensions_stanzas);
      return t)
 
 let load_dune_project ~dir packages =
diff --git a/src/dune_project.mli b/src/dune_project.mli
index c795c728..9ffcccdc 100644
--- a/src/dune_project.mli
+++ b/src/dune_project.mli
@@ -73,18 +73,16 @@ module Extension : sig
   (** One version of an extension *)
   type t
 
-  (** [make version args_spec f] defines one version of an
-      extension. Users will enable this extension by writing:
+  (** [make version parser] defines one version of an extension. Users will
+      enable this extension by writing:
 
       {[ (using <name> <version> <args>) ]}
 
-      in their [dune-project] file. [args_spec] is used to describe
-      what [<args>] might be.
-  *)
+      in their [dune-project] file. [parser] is used to describe
+      what [<args>] might be.  *)
   val make
     :  Syntax.Version.t
-    -> ('a, Stanza.Parser.t list) Sexp.Of_sexp.Constructor_args_spec.t
-    -> (project -> 'a)
+    -> (project -> Stanza.Parser.t list Sexp.Of_sexp.cstr_parser)
     -> t
 
   (** Register all the supported versions of an extension *)
diff --git a/src/file_tree.ml b/src/file_tree.ml
index 16603cbe..87007c8a 100644
--- a/src/file_tree.ml
+++ b/src/file_tree.ml
@@ -52,7 +52,7 @@ module Dune_file = struct
           dn
       in
       sum
-        [ cstr "ignored_subdirs" (list sub_dir @> nil) String.Set.of_list
+        [ "ignored_subdirs", next (list sub_dir) >>| String.Set.of_list
         ]
     in
     fun sexps ->
diff --git a/src/inline_tests.ml b/src/inline_tests.ml
index 2b140231..334d6010 100644
--- a/src/inline_tests.ml
+++ b/src/inline_tests.ml
@@ -27,7 +27,7 @@ module Backend = struct
       let short = None
       let parse =
         record
-          (record_loc >>= fun loc ->
+          (list_loc >>= fun loc ->
            field "runner_libraries" (list (located string)) ~default:[]
            >>= fun runner_libraries ->
            Ordered_set_lang.Unexpanded.field "flags" >>= fun flags ->
@@ -135,7 +135,7 @@ include Sub_system.Register_end_point(
     let short = Some empty
     let parse =
       record
-        (record_loc >>= fun loc ->
+        (list_loc >>= fun loc ->
          field "deps" (list Dep_conf.t) ~default:[] >>= fun deps ->
          Ordered_set_lang.Unexpanded.field "flags" >>= fun flags ->
          field_o "backend" (located string) >>= fun backend ->
diff --git a/src/installed_dune_file.ml b/src/installed_dune_file.ml
index fcd88858..ac540fa7 100644
--- a/src/installed_dune_file.ml
+++ b/src/installed_dune_file.ml
@@ -35,8 +35,10 @@ let of_sexp =
       of_sexp_error sexp "Unsupported version, only version 1 is supported"
   in
   sum
-    [ cstr "dune" (version @> list raw @> nil)
-        (fun () l -> parse_sub_systems l)
+    [ "dune",
+      (next version >>= fun () ->
+       next (list raw) >>| fun l ->
+       parse_sub_systems l)
     ]
 
 let load fname = of_sexp (Io.Sexp.load ~mode:Single fname)
diff --git a/src/jbuild.ml b/src/jbuild.ml
index 4ca451fb..0022c7f8 100644
--- a/src/jbuild.ml
+++ b/src/jbuild.ml
@@ -208,17 +208,15 @@ module Dep_conf = struct
 
   let t =
     let t =
-      let cstr_sw name f =
-        cstr name (String_with_vars.t @> nil) f
-      in
+      let sw = String_with_vars.t in
       sum
-        [ cstr_sw "file"                 (fun x -> File x)
-        ; cstr_sw "alias"                (fun x -> Alias x)
-        ; cstr_sw "alias_rec"            (fun x -> Alias_rec x)
-        ; cstr_sw "glob_files"           (fun x -> Glob_files x)
-        ; cstr_sw "files_recursively_in" (fun x -> Files_recursively_in x)
-        ; cstr_sw "package"              (fun x -> Package x)
-        ; cstr    "universe" nil         Universe
+        [ "file"                 , (next sw >>| fun x -> File x)
+        ; "alias"                , (next sw >>| fun x -> Alias x)
+        ; "alias_rec"            , (next sw >>| fun x -> Alias_rec x)
+        ; "glob_files"           , (next sw >>| fun x -> Glob_files x)
+        ; "files_recursively_in" , (next sw >>| fun x -> Files_recursively_in x)
+        ; "package"              , (next sw >>| fun x -> Package x)
+        ; "universe"             , return Universe
         ]
     in
     fun sexp ->
@@ -257,12 +255,15 @@ module Preprocess = struct
 
   let t =
     sum
-      [ cstr "no_preprocessing" nil No_preprocessing
-      ; cstr "action" (located Action.Unexpanded.t @> nil) (fun (loc, x) ->
-          Action (loc, x))
-      ; cstr "pps" (cstr_loc (list Pp_or_flags.t @> nil)) (fun loc l ->
-          let pps, flags = Pp_or_flags.split l in
-          Pps { loc; pps; flags })
+      [ "no_preprocessing", return No_preprocessing
+      ; "action",
+        (next (located Action.Unexpanded.t) >>| fun (loc, x) ->
+         Action (loc, x))
+      ; "pps",
+        (list_loc >>= fun loc ->
+         next (list Pp_or_flags.t) >>| fun l ->
+         let pps, flags = Pp_or_flags.split l in
+         Pps { loc; pps; flags })
       ]
 
   let pps = function
@@ -469,7 +470,7 @@ module Buildable = struct
     field name Ordered_set_lang.t ~default:Ordered_set_lang.standard
 
   let v1 =
-    record_loc >>= fun loc ->
+    list_loc >>= fun loc ->
     field "preprocess" Preprocess_map.t ~default:Preprocess_map.default
     >>= fun preprocess ->
     field "preprocessor_deps" (list Dep_conf.t) ~default:[]
@@ -1261,40 +1262,62 @@ module Stanzas = struct
 
   type Stanza.t += Include of Loc.t * string
 
-  type constructors = Stanza.t list Sexp.Of_sexp.Constructor_spec.t list
+  type constructors = (string * Stanza.t list Sexp.Of_sexp.cstr_parser) list
 
   let common project ~syntax : constructors =
-    [ cstr "library"     (Library.v1 project @> nil) (fun x -> [Library x])
-    ; cstr "executable"  (Executables.single project ~syntax @> nil) execs
-    ; cstr "executables" (Executables.multi  project ~syntax @> nil) execs
-    ; cstr "rule"        (cstr_loc (Rule.v1 @> nil)) (fun loc x -> [Rule { x with loc }])
-    ; cstr "ocamllex"    (cstr_loc (Rule.ocamllex_v1 @> nil))
-        (fun loc x -> rules (Rule.ocamllex_to_rule loc x))
-    ; cstr "ocamlyacc"   (cstr_loc (Rule.ocamlyacc_v1 @> nil))
-        (fun loc x -> rules (Rule.ocamlyacc_to_rule loc x))
-    ; cstr "menhir"      (cstr_loc (Menhir.v1 @> nil))
-        (fun loc x -> [Menhir { x with loc }])
-    ; cstr "install"     (Install_conf.v1 project @> nil) (fun x -> [Install     x])
-    ; cstr "alias"       (Alias_conf.v1 project @> nil)   (fun x -> [Alias       x])
-    ; cstr "copy_files" (Copy_files.v1 @> nil)
-        (fun glob -> [Copy_files {add_line_directive = false; glob}])
-    ; cstr "copy_files#" (Copy_files.v1 @> nil)
-        (fun glob -> [Copy_files {add_line_directive = true; glob}])
-    ; cstr "include" (cstr_loc (relative_file @> nil)) (fun loc fn ->
-        [Include (loc, fn)])
-    ; cstr "documentation" (Documentation.v1 project @> nil)
-        (fun d -> [Documentation d])
+    [ "library",
+      (next (Library.v1 project) >>| fun x ->
+       [Library x])
+    ; "executable" , next (Executables.single project ~syntax) >>| execs
+    ; "executables", next (Executables.multi  project ~syntax) >>| execs
+    ; "rule",
+      (list_loc >>= fun loc ->
+       next Rule.v1 >>| fun x ->
+       [Rule { x with loc }])
+    ; "ocamllex",
+      (list_loc >>= fun loc ->
+       next Rule.ocamllex_v1 >>| fun x ->
+       rules (Rule.ocamllex_to_rule loc x))
+    ; "ocamlyacc",
+      (list_loc >>= fun loc ->
+       next Rule.ocamlyacc_v1 >>| fun x ->
+       rules (Rule.ocamlyacc_to_rule loc x))
+    ; "menhir",
+      (list_loc >>= fun loc ->
+       next Menhir.v1 >>| fun x ->
+       [Menhir { x with loc }])
+    ; "install",
+      (next (Install_conf.v1 project) >>| fun x ->
+       [Install x])
+    ; "alias",
+      (next (Alias_conf.v1 project) >>| fun x ->
+       [Alias x])
+    ; "copy_files",
+      (next Copy_files.v1 >>| fun glob ->
+       [Copy_files {add_line_directive = false; glob}])
+    ; "copy_files#",
+      (next Copy_files.v1 >>| fun glob ->
+       [Copy_files {add_line_directive = true; glob}])
+    ; "include",
+      (list_loc >>= fun loc ->
+       next relative_file >>| fun fn ->
+       [Include (loc, fn)])
+    ; "documentation",
+      (next (Documentation.v1 project) >>| fun d ->
+       [Documentation d])
     ]
 
   let dune project =
     common project ~syntax:Dune @
-    [ cstr "env" (cstr_loc (rest Env.rule))
-        (fun loc rules -> [Env { loc; rules }])
+    [ "env",
+      (list_loc >>= fun loc ->
+       rest Env.rule >>| fun rules ->
+       [Env { loc; rules }])
     ]
 
   let jbuild project =
     common project ~syntax:Jbuild @
-    [ cstr "jbuild_version" (Jbuild_version.t @> nil) (fun _ -> [])
+    [ "jbuild_version", (next Jbuild_version.t >>| fun _ -> [])
     ]
 
   let () =
diff --git a/src/preprocessing.ml b/src/preprocessing.ml
index 5bb68740..8fb1614c 100644
--- a/src/preprocessing.ml
+++ b/src/preprocessing.ml
@@ -37,7 +37,7 @@ module Driver = struct
       let short = None
       let parse =
         record
-          (record_loc >>= fun loc ->
+          (list_loc >>= fun loc ->
            Ordered_set_lang.Unexpanded.field "flags"      >>= fun      flags ->
            Ordered_set_lang.Unexpanded.field "lint_flags" >>= fun lint_flags ->
            field "main" string >>= fun main ->
diff --git a/src/stanza.ml b/src/stanza.ml
index 77cf482f..a490a830 100644
--- a/src/stanza.ml
+++ b/src/stanza.ml
@@ -3,5 +3,5 @@ open Stdune
 type t = ..
 
 module Parser = struct
-  type nonrec t = t list Sexp.Of_sexp.Constructor_spec.t
+  type nonrec t = string * t list Sexp.Of_sexp.cstr_parser
 end
diff --git a/src/stanza.mli b/src/stanza.mli
index 0262f7b8..b2c979f5 100644
--- a/src/stanza.mli
+++ b/src/stanza.mli
@@ -9,5 +9,5 @@ module Parser : sig
 
       Each stanza in a configuration file might produce several values
       of type [t], hence the [t list] here. *)
-  type nonrec t = t list Sexp.Of_sexp.Constructor_spec.t
+  type nonrec t = string * t list Sexp.Of_sexp.cstr_parser
 end
diff --git a/src/stdune/path.ml b/src/stdune/path.ml
index 4c66fa34..8cb1e572 100644
--- a/src/stdune/path.ml
+++ b/src/stdune/path.ml
@@ -594,10 +594,11 @@ let t = function
   | s ->
     let open Sexp.Of_sexp in
     sum
-      [ cstr "In_build_dir" (Local.t @> nil) in_build_dir
-      ; cstr "In_source_tree" (Local.t @> nil) in_source_tree
-      ; cstr "External" (External.t @> nil) external_
-      ] s
+      [ "In_build_dir"  , next Local.t    >>| in_build_dir
+      ; "In_source_tree", next Local.t    >>| in_source_tree
+      ; "External"      , next External.t >>| external_
+      ]
+      s
 
 let sexp_of_t t =
   let constr f x y = Sexp.To_sexp.(pair string f) (x, y) in
diff --git a/src/stdune/sexp.ml b/src/stdune/sexp.ml
index 5dae125e..1fe2d356 100644
--- a/src/stdune/sexp.ml
+++ b/src/stdune/sexp.ml
@@ -80,8 +80,8 @@ module Of_sexp = struct
   let of_sexp_error ?hint sexp str = raise (Of_sexp (Ast.loc sexp, str, hint))
   let of_sexp_errorf ?hint sexp fmt = Printf.ksprintf (of_sexp_error ?hint sexp) fmt
 
-  let of_sexp_errorf_loc loc fmt =
-    Printf.ksprintf (fun s -> raise (Of_sexp (loc, s, None))) fmt
+  let of_sexp_errorf_loc ?hint loc fmt =
+    Printf.ksprintf (fun s -> raise (Of_sexp (loc, s, hint))) fmt
 
   let raw x = x
 
@@ -158,49 +158,53 @@ module Of_sexp = struct
 
   module Name_map = Map.Make(Name)
 
-  type record_parser_state =
-    { loc      : Loc.t
-    ; unparsed : unparsed_field Name_map.t
-    ; known    : string list
-    }
+  (* Either:
 
-  type 'a record_parser = record_parser_state -> 'a * record_parser_state
+     - [Sum (<list location>, <constructor name>, <elements>)]
+     - [Record (<list location>, <unparsed fields>, <known field names>)]
+  *)
+  type 'kind list_parser_state =
+    | Cstr
+      : Loc.t * string * Ast.t list -> [`Cstr] list_parser_state
+    | Record
+      : Loc.t * unparsed_field Name_map.t * string list
+      -> [`Record] list_parser_state
+
+  type ('a, 'kind) list_parser
+    = 'kind list_parser_state -> 'a * 'kind list_parser_state
+
+  type 'a   cstr_parser = ('a, [`Cstr  ]) list_parser
+  type 'a record_parser = ('a, [`Record]) list_parser
 
   let return x state = (x, state)
   let (>>=) m f state =
     let x, state = m state in
     f x state
+  let (>>|) m f state =
+    let x, state = m state in
+    (f x, state)
 
-  let record_loc state =
-    (state.loc, state)
+  let get_loc : type k. k list_parser_state -> Loc.t = function
+    | Cstr   (loc, _, _) -> loc
+    | Record (loc, _, _) -> loc
 
-  let consume name state =
-    { state with
-      unparsed = Name_map.remove state.unparsed name
-    ; known    = name :: state.known
-    }
+  let list_loc state = (get_loc state, state)
 
-  let add_known name state =
-    { state with known = name :: state.known }
+  let consume name (Record (loc, unparsed, known)) =
+    Record (loc, Name_map.remove unparsed name, name :: known)
 
-  let ignore_fields names state =
-    let unparsed =
-      List.fold_left names ~init:state.unparsed ~f:(fun acc name ->
-        Name_map.remove acc name)
-    in
-    ((),
-     { state with
-       unparsed
-     ; known = List.rev_append names state.known
-     })
+  let add_known name (Record (loc, unparsed, known)) =
+    (Record (loc, unparsed, name :: known))
 
-  let map_validate parse ~f state =
-    let x, state' = parse state in
+  let map_validate parse ~f state1 =
+    let x, state2 = parse state1 in
     match f x with
-    | Result.Ok x -> x, state'
+    | Result.Ok x -> x, state2
     | Error msg ->
+      let (Record (_, unparsed1, _)) = state1 in
+      let (Record (_, unparsed2, _)) = state2 in
       let parsed =
-        Name_map.merge state.unparsed state'.unparsed ~f:(fun _key before after ->
+        Name_map.merge unparsed1 unparsed2 ~f:(fun _key before after ->
           match before, after with
           | Some _, None -> before
           | _ -> None)
@@ -212,7 +216,7 @@ module Of_sexp = struct
           |> List.sort ~compare:(fun a b ->
             Int.compare a.Loc.start.pos_cnum b.start.pos_cnum)
         with
-        | [] -> state.loc
+        | [] -> get_loc state1
         | first :: l ->
           let last = List.fold_left l ~init:first ~f:(fun _ x -> x) in
           { first with stop = last.stop }
@@ -236,7 +240,7 @@ module Of_sexp = struct
     of_sexp_errorf_loc (Ast.loc field.entry) "too many values for field %s" name
 
   let field_missing state name =
-    of_sexp_errorf_loc state.loc "field %s missing" name
+    of_sexp_errorf_loc (get_loc state) "field %s missing" name
 
   let rec multiple_occurrences ~name ~last ~prev =
     match prev.prev with
@@ -247,8 +251,8 @@ module Of_sexp = struct
       of_sexp_errorf last.entry "Field %S is present too many times" name
   [@@inline never]
 
-  let find_single state name =
-    let res = Name_map.find state.unparsed name in
+  let find_single (Record (_, unparsed, _)) name =
+    let res = Name_map.find unparsed name in
     (match res with
      | Some ({ prev = Some prev; _ } as last) ->
        multiple_occurrences ~name ~last ~prev
@@ -294,40 +298,31 @@ module Of_sexp = struct
       | Some f ->
         too_many_values name f
     in
-    let res = loop [] (Name_map.find state.unparsed name) in
+    let (Record (_, unparsed, _)) = state in
+    let res = loop [] (Name_map.find unparsed name) in
     (res, consume name state)
 
-  let make_record_parser_state sexp =
-    match sexp with
-    | Atom _ | Quoted_string _ -> of_sexp_error sexp "List expected"
-    | List (loc, sexps) ->
-      let unparsed =
-        List.fold_left sexps ~init:Name_map.empty ~f:(fun acc sexp ->
-          match sexp with
-          | List (_, name_sexp :: values) -> begin
-              match name_sexp with
-              | Atom (_, A name) ->
-                Name_map.add acc name
-                  { values
-                  ; entry = sexp
-                  ; prev  = Name_map.find acc name
-                  }
-              | List _ | Quoted_string _ ->
-                of_sexp_error name_sexp "Atom expected"
-            end
-          | _ ->
-            of_sexp_error sexp
-              "S-expression of the form (<name> <values>...) expected")
-      in
-      { loc    = loc
-      ; known  = []
-      ; unparsed
-      }
-
-  let record parse sexp =
-    let state = make_record_parser_state sexp in
-    let v, state = parse state in
-    match Name_map.choose state.unparsed with
+  let parse_fields m loc sexps =
+    let unparsed =
+      List.fold_left sexps ~init:Name_map.empty ~f:(fun acc sexp ->
+        match sexp with
+        | List (_, name_sexp :: values) -> begin
+            match name_sexp with
+            | Atom (_, A name) ->
+              Name_map.add acc name
+                { values
+                ; entry = sexp
+                ; prev  = Name_map.find acc name
+                }
+            | List _ | Quoted_string _ ->
+              of_sexp_error name_sexp "Atom expected"
+          end
+        | _ ->
+          of_sexp_error sexp
+            "S-expression of the form (<name> <values>...) expected")
+    in
+    let v, (Record (_, unparsed, known)) = m (Record (loc, unparsed, [])) in
+    match Name_map.choose unparsed with
     | None -> v
     | Some (name, { entry; _ }) ->
       let name_sexp =
@@ -335,129 +330,89 @@ module Of_sexp = struct
         | List (_, s :: _) -> s
         | _ -> assert false
       in
-      of_sexp_errorf ~hint:({ on = name ; candidates = state.known})
+      of_sexp_errorf ~hint:({ on = name ; candidates = known})
         name_sexp "Unknown field %s" name
 
-  module Constructor_args_spec = struct
-    type 'a conv = 'a t
-    type ('a, 'b) t =
-      | Nil    : ('a, 'a) t
-      | Rest   : 'a conv -> ('a  list -> 'b, 'b) t
-      | Record : 'a record_parser -> ('a -> 'b, 'b) t
-      | Loc    : ('a, 'b) t -> (Loc.t -> 'a, 'b) t
-      | Cons   : 'a conv * ('b, 'c) t -> ('a -> 'b, 'c) t
+  let record m sexp =
+    match sexp with
+    | Atom _ | Quoted_string _ -> of_sexp_error sexp "List expected"
+    | List (loc, sexps) -> parse_fields m loc sexps
 
-    let rec convert : type a b. (a, b) t -> Ast.t -> Ast.t list -> a -> b
-      = fun t sexp sexps f ->
-        match t, sexps with
-        | Nil, [] -> f
-        | Rest conv, l -> f (List.map l ~f:conv)
-        | Record rp, l -> begin
-            match sexp with
-            | Atom (_, A s) | Quoted_string (_, s) ->
-              of_sexp_errorf sexp "'%s' expect arguments" s
-            | List (loc, _) ->
-              f (record rp (List (loc, l)))
-          end
-        | Loc t, l -> convert t sexp l (f (Ast.loc sexp))
-        | Cons (conv, t), s :: l -> convert t sexp l (f (conv s))
-        | Cons _, [] -> of_sexp_error sexp "not enough arguments"
-        | Nil, _ :: _ -> of_sexp_error sexp "too many arguments"
+  let next t (Cstr (loc, cstr, sexps)) =
+    match sexps with
+    | [] -> of_sexp_errorf_loc loc "Not enough arguments for %s" cstr
+    | sexp :: sexps ->
+      let v = t sexp in
+      (v, Cstr (loc, cstr, sexps))
 
-    let parse t sexp f =
-      match sexp with
-      | Atom _ | Quoted_string _ ->
-        of_sexp_error sexp "List expected"
-      | List (_, l) -> convert t sexp l f
-  end
+  let rest t (Cstr (loc, cstr, sexps)) =
+    (List.map sexps ~f:t,
+     Cstr (loc, cstr, []))
 
-  let nil = Constructor_args_spec.Nil
-  let ( @> ) a b = Constructor_args_spec.Cons (a, b)
-  let rest f = Constructor_args_spec.Rest f
-  let cstr_loc x = Constructor_args_spec.Loc x
-  let rest_as_record rp = Constructor_args_spec.Record rp
+  let rest_as_record m (Cstr (loc, cstr, sexps)) =
+    let v = parse_fields m loc sexps in
+    (v, Cstr (loc, cstr, []))
 
-  let field_multi name ?default args_spec f state =
+  let sum_result (v, Cstr (loc, cstr, sexps)) =
+    match sexps with
+    | [] -> v
+    | _ :: _ -> of_sexp_errorf_loc loc "Too many arguments for %s" cstr
+
+  let find_cstr cstrs loc name state =
+    match List.assoc cstrs name with
+    | Some m -> sum_result (m state)
+    | None ->
+      of_sexp_errorf_loc loc
+        ~hint:{ on         = name
+              ; candidates = List.map cstrs ~f:fst
+              }
+        "Unknown constructor %s" name
+
+  let sum cstrs sexp =
+    match sexp with
+    | Atom (loc, A s) ->
+      find_cstr cstrs loc s (Cstr (loc, s, []))
+    | Quoted_string _ -> of_sexp_error sexp "Atom expected"
+    | List (_, []) -> of_sexp_error sexp "non-empty list expected"
+    | List (loc, name :: args) ->
+      match name with
+      | Quoted_string _ | List _ -> of_sexp_error name "Atom expected"
+      | Atom (s_loc, A s) ->
+        find_cstr cstrs s_loc s (Cstr (loc, s, args))
+
+  let field_multi name ?default m state =
     match find_single state name with
     | Some { values; entry; _ } ->
-      (Constructor_args_spec.convert args_spec entry values f,
+      (sum_result (m (Cstr (Ast.loc entry, name, values))),
        consume name state)
     | None ->
       match default with
       | Some v -> (v, add_known name state)
       | None -> field_missing state name
 
-  let dup_field_multi name args_spec f state =
+  let dup_field_multi name m state =
     let rec loop acc field =
       match field with
       | None -> acc
       | Some { values; entry; prev } ->
-        let x =
-          Constructor_args_spec.convert args_spec entry values f
-        in
+        let x = sum_result (m (Cstr (Ast.loc entry, name, values))) in
         loop (x :: acc) prev
     in
-    let res = loop [] (Name_map.find state.unparsed name) in
+    let (Record (_, unparsed, _)) = state in
+    let res = loop [] (Name_map.find unparsed name) in
     (res, consume name state)
 
-  module Constructor_spec = struct
-    type ('a, 'b) unpacked =
-      { name : string
-      ; args : ('a, 'b) Constructor_args_spec.t
-      ; make : 'a
-      }
-
-    type 'a t = T : (_, 'a) unpacked -> 'a t [@@unboxed]
-
-    let name (T t) = t.name
-  end
-  module C = Constructor_spec
-
-  let cstr name args make = C.T { name; args; make }
-
-  let equal_cstr_name a b = Name.compare a b = Eq
-
-  let find_cstr cstrs sexp name =
-    match
-      List.find cstrs ~f:(fun cstr ->
-        equal_cstr_name (C.name cstr) name)
-    with
-    | Some cstr -> cstr
-    | None ->
-      of_sexp_errorf sexp
-        ~hint:{ on = String.uncapitalize name
-              ; candidates = List.map cstrs ~f:C.name
-              }
-        "Unknown constructor %s" name
-
-  let sum cstrs sexp =
-    match sexp with
-    | Atom (_, A s) ->
-      let (C.T cstr) = find_cstr cstrs sexp s in
-      Constructor_args_spec.convert cstr.args sexp [] cstr.make
-    | Quoted_string _ -> of_sexp_error sexp "Atom expected"
-    | List (_, []) -> of_sexp_error sexp "non-empty list expected"
-    | List (_, name_sexp :: args) ->
-      match name_sexp with
-      | Quoted_string _ | List _ -> of_sexp_error name_sexp "Atom expected"
-      | Atom (_, A s) ->
-        let (C.T cstr) = find_cstr cstrs sexp s in
-        Constructor_args_spec.convert cstr.args sexp args cstr.make
-
   let enum cstrs sexp =
     match sexp with
     | Quoted_string _ | List _ -> of_sexp_error sexp "Atom expected"
     | Atom (_, A s) ->
-      match
-        List.find cstrs ~f:(fun (name, _) ->
-          equal_cstr_name name s)
-      with
-      | Some (_, value) -> value
+      match List.assoc cstrs s with
+      | Some value -> value
       | None ->
         of_sexp_errorf sexp
-          ~hint:{ on = String.uncapitalize s
-                ; candidates =List.map cstrs ~f:(fun (name, _) ->
-                    String.uncapitalize name) }
+          ~hint:{ on         = s
+                ; candidates = List.map cstrs ~f:fst
+                }
           "Unknown value %s" s
 end
 
diff --git a/src/stdune/sexp.mli b/src/stdune/sexp.mli
index eff1a7aa..0d87369e 100644
--- a/src/stdune/sexp.mli
+++ b/src/stdune/sexp.mli
@@ -74,13 +74,57 @@ module Of_sexp : sig
 
   val raw : ast t
 
-  (* Record parsing monad *)
-  type 'a record_parser
-  val return : 'a -> 'a record_parser
-  val ( >>= ) : 'a record_parser -> ('a -> 'b record_parser) -> 'b record_parser
+  val enum : (string * 'a) list -> 'a t
 
-  (** Return the location of the record being parsed *)
-  val record_loc : Loc.t record_parser
+  (** {2 Parsing lists} *)
+
+  (** Monad for parsing lists *)
+  type ('a, 'kind) list_parser
+
+  type 'a   cstr_parser = ('a, [`Cstr  ]) list_parser
+  type 'a record_parser = ('a, [`Record]) list_parser
+
+  val return : 'a -> ('a, _) list_parser
+  val ( >>= )
+    :  ('a, 'kind) list_parser
+    -> ('a -> ('b, 'kind) list_parser)
+    -> ('b, 'kind) list_parser
+  val ( >>| )
+    :  ('a, 'kind) list_parser
+    -> ('a -> 'b)
+    -> ('b, 'kind) list_parser
+
+  (** Return the location of the list being parsed *)
+  val list_loc : (Loc.t, _) list_parser
+
+  (** Parser that parse a record, i.e. a list of s-expressions of the
+      form [(<atom> <s-exp>)]. *)
+  val record : 'a record_parser -> 'a t
+
+  (** Parser that parse a S-expression of the form [(<atom> <s-exp1>
+      <s-exp2> ...)] or [<atom>]. [<atom>] is looked up in the list and
+      the remaining s-expressions are parsed using the corresponding
+      list parser. *)
+  val sum : (string * 'a cstr_parser) list -> 'a t
+
+  (** Parse and consume the next element of the list *)
+  val next : 'a t -> 'a cstr_parser
+
+  (** Parse and consume the rest of the list as a list of element of
+      the same type. *)
+  val rest : 'a t -> 'a list cstr_parser
+
+  (** Parse all remaining elements as a list of fields *)
+  val rest_as_record : 'a record_parser -> 'a cstr_parser
+
+  (** Check the result of a list parser, and raise a properly located
+      error in case of failure. *)
+  val map_validate
+    :  'a record_parser
+    -> f:('a -> ('b, string) Result.t)
+    -> 'b record_parser
+
+  (** {3 Parsing record fields} *)
 
   module Short_syntax : sig
     type 'a t =
@@ -109,69 +153,19 @@ module Of_sexp : sig
     -> 'a t
     -> 'a list record_parser
 
-  val map_validate
-    :  'a record_parser
-    -> f:('a -> ('b, string) Result.result)
-    -> 'b record_parser
-
-  val ignore_fields : string list -> unit record_parser
-
-  val record : 'a record_parser -> 'a t
-
-  module Constructor_spec : sig
-    type 'a t
-  end
-
-  module Constructor_args_spec : sig
-    type ('a, 'b) t
-
-    val parse : ('a, 'b) t -> Ast.t -> 'a -> 'b
-  end
-
-  val nil : ('a, 'a) Constructor_args_spec.t
-  val ( @> )
-    :  'a t
-    -> ('b, 'c) Constructor_args_spec.t
-    -> ('a -> 'b, 'c) Constructor_args_spec.t
-
-  (** Parse all remaining arguments using the following parser *)
-  val rest : 'a t -> ('a list -> 'b, 'b) Constructor_args_spec.t
-
-  (** Parse all remaining arguments using the following record parser *)
-  val rest_as_record : 'a record_parser -> ('a -> 'b, 'b) Constructor_args_spec.t
-
-  (** Capture the location of the constructor *)
-  val cstr_loc
-    :  ('a, 'b) Constructor_args_spec.t
-    -> (Loc.t -> 'a, 'b) Constructor_args_spec.t
-
   (** Field that takes multiple values *)
   val field_multi
     :  string
-    -> ?default:'b
-    -> ('a, 'b) Constructor_args_spec.t
-    -> 'a
-    -> 'b record_parser
+    -> ?default:'a
+    -> 'a cstr_parser
+    -> 'a record_parser
 
   (** A field that can appear multiple times and each time takes
       multiple values *)
   val dup_field_multi
     :  string
-    -> ('a, 'b) Constructor_args_spec.t
-    -> 'a
-    -> 'b list record_parser
-
-  val cstr
-    :  string
-    -> ('a, 'b) Constructor_args_spec.t
-    -> 'a
-    -> 'b Constructor_spec.t
-
-  val sum
-    :  'a Constructor_spec.t list
-    -> 'a t
-
-  val enum : (string * 'a) list -> 'a t
+    -> 'a cstr_parser
+    -> 'a list record_parser
 end
 
 module type Sexpable = sig
diff --git a/src/workspace.ml b/src/workspace.ml
index 734f9545..aa288ff1 100644
--- a/src/workspace.ml
+++ b/src/workspace.ml
@@ -63,12 +63,12 @@ module Context = struct
     | List (_, List _ :: _) as sexp -> Opam (record (Opam.t ~profile) sexp)
     | sexp ->
       sum
-        [ cstr "default"
-            (rest_as_record (Default.t ~profile))
-            (fun x -> Default x)
-        ; cstr "opam"
-            (rest_as_record (Opam.t ~profile))
-            (fun x -> Opam x)
+        [ "default",
+          (rest_as_record (Default.t ~profile) >>| fun x ->
+           Default x)
+        ; "opam",
+          (rest_as_record (Opam.t ~profile) >>| fun x ->
+           Opam x)
         ]
         sexp
 
@@ -96,8 +96,11 @@ type item = Context of Sexp.Ast.t | Profile of Loc.t * string
 
 let item_of_sexp =
   sum
-    [ cstr "context" (raw @> nil) (fun x -> Context x)
-    ; cstr "profile" (cstr_loc (string @> nil)) (fun loc x -> Profile (loc, x))
+    [ "context", (next raw >>|fun x -> Context x)
+    ; "profile",
+      (list_loc >>= fun loc ->
+       next string >>= fun x ->
+       return (Profile (loc, x)))
     ]
 
 let t ?x ?profile:cmdline_profile sexps =