From 26cb92f814b82573d23ff7adcaa662b2f3511245 Mon Sep 17 00:00:00 2001
From: Rudi Grinberg <me@rgrinberg.com>
Date: Sat, 29 Nov 2025 19:16:12 +0000
Subject: [PATCH 1/2] dev

Signed-off-by: Rudi Grinberg <me@rgrinberg.com>

From ff1b0414ed21e149e03243d3af3bec80551b1deb Mon Sep 17 00:00:00 2001
From: Rudi Grinberg <me@rgrinberg.com>
Date: Fri, 21 Nov 2025 17:37:51 +0000
Subject: [PATCH 2/2] refactor: defunctionalize dune_sexp

Necessary to implement either in a non hacky way (amongst other things)

Signed-off-by: Rudi Grinberg <me@rgrinberg.com>
---
 src/dune_lang/targets_spec.ml |   8 +-
 src/dune_rules/module.ml      |   3 +-
 src/dune_sexp/decoder.ml      | 980 +++++++++++++++++++---------------
 src/dune_sexp/decoder.mli     |  14 +-
 4 files changed, 565 insertions(+), 440 deletions(-)

diff --git a/src/dune_lang/targets_spec.ml b/src/dune_lang/targets_spec.ml
index 640b4949e6d..0267f0e6805 100644
--- a/src/dune_lang/targets_spec.ml
+++ b/src/dune_lang/targets_spec.ml
@@ -44,10 +44,11 @@ type 'a t =
   | Infer
 
 let decode_target ~allow_directory_targets =
+  let module K = Kind in
   let open Dune_sexp.Decoder in
   let file =
     let+ file = String_with_vars.decode in
-    file, Kind.File
+    file, K.File
   in
   let dir =
     let+ dir = sum ~force_parens:true [ "dir", String_with_vars.decode ] in
@@ -56,18 +57,19 @@ let decode_target ~allow_directory_targets =
       User_error.raise
         ~loc:(String_with_vars.loc dir)
         [ Pp.text "Directory targets require the 'directory-targets' extension" ];
-    dir, Kind.Directory
+    dir, K.Directory
   in
   file <|> dir
 ;;
 
 let decode_static ~allow_directory_targets =
+  let module K = Kind in
   let open Dune_sexp.Decoder in
   let+ syntax_version = Syntax.get_exn Stanza.syntax
   and+ targets = repeat (decode_target ~allow_directory_targets) in
   if syntax_version < (1, 3)
   then
-    List.iter targets ~f:(fun (target, (_ : Kind.t)) ->
+    List.iter targets ~f:(fun (target, (_ : K.t)) ->
       if String_with_vars.has_pforms target
       then
         Syntax.Error.since
diff --git a/src/dune_rules/module.ml b/src/dune_rules/module.ml
index ebaf4efbcc7..ec3d21b4135 100644
--- a/src/dune_rules/module.ml
+++ b/src/dune_rules/module.ml
@@ -379,11 +379,12 @@ let encode ({ source; obj_name; pp = _; visibility; kind; install_as = _ } as t)
 ;;
 
 let decode ~src_dir =
+  let module K = Kind in
   let open Dune_lang.Decoder in
   fields
     (let+ obj_name = field "obj_name" Module_name.Unique.decode
      and+ visibility = field "visibility" Visibility.decode
-     and+ kind = field_o "kind" Kind.decode
+     and+ kind = field_o "kind" K.decode
      and+ source = field "source" (Source.decode ~dir:src_dir) in
      let kind =
        match kind with
diff --git a/src/dune_sexp/decoder.ml b/src/dune_sexp/decoder.ml
index a963ba4cf3f..84b327dfd16 100644
--- a/src/dune_sexp/decoder.ml
+++ b/src/dune_sexp/decoder.ml
@@ -116,106 +116,92 @@ type 'kind context =
   | Values : Loc.t * string option * Univ_map.t -> values context
   | Fields : Loc.t * string option * Univ_map.t -> Fields.t context
 
-type ('a, 'kind) parser = 'kind context -> 'kind -> 'a * 'kind
-type 'a t = ('a, values) parser
-type 'a fields_parser = ('a, Fields.t) parser
-
-let return x _ctx state = x, state
-
-let ( >>= ) t f ctx state =
-  let x, state = t ctx state in
-  f x ctx state
-;;
-
-let ( >>| ) t f ctx state =
-  let x, state = t ctx state in
-  f x, state
-;;
-
-let ( >>> ) a b ctx state =
-  let (), state = a ctx state in
-  b ctx state
-;;
-
-let ( let* ) = ( >>= )
-let ( let+ ) = ( >>| )
+module Kind = struct
+  type t =
+    | Values of Loc.t * string option
+    | Fields of Loc.t * string option
+end
 
-let ( and+ ) a b ctx state =
-  let a, state = a ctx state in
-  let b, state = b ctx state in
-  (a, b), state
-;;
+type (_, _) parser =
+  | Return : 'a -> ('a, 'kind) parser
+  | Bind : ('a, 'kind) parser * ('a -> ('b, 'kind) parser) -> ('b, 'kind) parser
+  | Map : ('a, 'kind) parser * ('a -> 'b) -> ('b, 'kind) parser
+  | Map_validate :
+      ('a, 'b) parser * ('a -> ('c, User_message.t) result)
+      -> ('c, 'b) parser
+  | Seq : (unit, 'kind) parser * ('a, 'kind) parser -> ('a, 'kind) parser
+  | And : ('a, 'kind) parser * ('b, 'kind) parser -> ('a * 'b, 'kind) parser
+  | Lazy : ('a, 'kind) parser Lazy.t -> ('a, 'kind) parser
+  | Try : ('a, 'b) parser * (exn -> ('a, 'b) parser) -> ('a, 'b) parser
+  | Get : 'a Univ_map.Key.t -> ('a option, 'b) parser
+  | Get_all : (Univ_map.t, 'b) parser
+  | Set : 'a Univ_map.Key.t * 'a * ('b, 'k) parser -> ('b, 'k) parser
+  | Update_var :
+      'a Univ_map.Key.t * ('a option -> 'a option) * ('b, 'k) parser
+      -> ('b, 'k) parser
+  | Set_many : Univ_map.t * ('a, 'k) parser -> ('a, 'k) parser
+  | Loc : (Loc.t, 'k) parser
+  | Eos : (bool, 'k) parser
+  | Repeat : 'a t -> ('a list, values) parser
+  | Capture : (('a, 'b list) parser -> 'a, 'b list) parser
+  | Next : (Ast.t -> 'a) -> ('a, values) parser
+  | Enter : ('a, values) parser -> ('a, values) parser
+  | Peek : (Ast.t option, values) parser
+  | Peek_exn : (Ast.t, values) parser
+  | Junk_everything : (unit, 'k) parser
+  | Keyword : string -> (unit, values) parser
+  | Either : ('a, 'b) parser * ('c, 'b) parser -> (('a, 'c) either, 'b) parser
+  | Located : ('a, 'b) parser -> (Loc.t * 'a, 'b) parser
+  | Sum :
+      { force_parens : bool
+      ; cstrs : (string * ('a, values) parser) list
+      }
+      -> ('a, values) parser
+  | Enum : (string * ('a, values) parser) list -> ('a, values) parser
+  | Field :
+      { name : string
+      ; default : 'a option
+      ; on_dup : (Univ_map.t -> string -> Ast.t list -> unit) option
+      ; t : 'a t
+      }
+      -> ('a, fields) parser
+  | Field_opt :
+      { name : string
+      ; on_dup : (Univ_map.t -> string -> Ast.t list -> unit) option
+      ; t : 'a t
+      }
+      -> ('a option, fields) parser
+  | Multi_field :
+      { name : string
+      ; t : 'a t
+      }
+      -> ('a list, fields) parser
+  | Fields_parser : ('a, fields) parser -> ('a, values) parser
+  | Leftover_fields_generic :
+      { t : 'a t
+      ; names : string list
+      }
+      -> ('a list, fields) parser
+  | Leftover_fields : (Ast.t list, Fields.t) parser
+  | Traverse : 'a list * ('a -> ('b, 'c) parser) -> ('b list, 'c) parser
+  | Kind : (Kind.t, 'a) parser
+  | Fields_mutually_exclusive :
+      { on_dup : (Univ_map.t -> string -> Ast.t list -> unit) option
+      ; default : 'a option
+      ; fields : (string * 'a t) list
+      }
+      -> ('a, fields) parser
+  | Fix : (('a, 'b) parser -> ('a, 'b) parser) -> ('a, 'b) parser
 
-let map t ~f = t >>| f
+and 'a t = ('a, values) parser
 
-let try_ t f ctx state =
-  try t ctx state with
-  | exn -> f exn ctx state
-;;
+type 'a fields_parser = ('a, Fields.t) parser
 
 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 get_all ctx state = get_user_context ctx, 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.set uc key v)) state
-  | Fields (loc, cstr, uc) -> t (Fields (loc, cstr, Univ_map.set uc key v)) state
-;;
-
-let update_var
-  : type a b k.
-    a Univ_map.Key.t -> f:(a option -> a option) -> (b, k) parser -> (b, k) parser
-  =
-  fun key ~f t ctx state ->
-  match ctx with
-  | Values (loc, cstr, uc) -> t (Values (loc, cstr, Univ_map.update uc key ~f)) state
-  | Fields (loc, cstr, uc) -> t (Fields (loc, cstr, Univ_map.update uc key ~f)) state
-;;
-
-let set_many : type a k. Univ_map.t -> (a, k) parser -> (a, k) parser =
-  fun map t ctx state ->
-  match ctx with
-  | Values (loc, cstr, uc) -> t (Values (loc, cstr, Univ_map.superpose map uc)) state
-  | Fields (loc, cstr, uc) -> t (Fields (loc, cstr, Univ_map.superpose map uc)) state
-;;
-
-let loc : type k. k context -> k -> Loc.t * k =
-  fun ctx state ->
-  match ctx with
-  | Values (loc, _, _) -> loc, state
-  | Fields (loc, _, _) -> loc, state
-;;
-
-let eos : type k. k context -> k -> bool * k =
-  fun ctx state ->
-  match ctx with
-  | Values _ -> state = [], state
-  | Fields _ -> Name.Map.is_empty state.unparsed, state
-;;
-
-let repeat : 'a t -> 'a list t =
-  let rec loop t acc ctx l =
-    match l with
-    | [] -> List.rev acc, []
-    | _ ->
-      let x, l = t ctx l in
-      loop t (x :: acc) ctx l
-  in
-  fun t ctx state -> loop t [] ctx state
-;;
-
-let repeat1 p =
-  let+ x = p
-  and+ xs = repeat p in
-  x :: xs
-;;
-
 let result : type a k. k context -> a * k -> a =
   fun ctx (v, state) ->
   match ctx with
@@ -242,73 +228,485 @@ let result : type a k. k context -> a * k -> a =
          [ Pp.textf "Unknown field %S" name ])
 ;;
 
-let parse t context sexp =
-  let ctx = Values (Ast.loc sexp, None, context) in
-  result ctx (t ctx [ sexp ])
-;;
-
-let capture ctx state =
-  let f t = result ctx (t ctx state) in
-  f, []
-;;
-
-let lazy_ t =
-  let+ f = capture in
-  lazy (f t)
-;;
-
-let end_of_list (Values (loc, cstr, _)) =
+let return x = Return x
+let ( >>= ) t f = Bind (t, f)
+let ( >>| ) t f = Map (t, f)
+let ( >>> ) a b = Seq (a, b)
+let ( let* ) = ( >>= )
+let ( let+ ) = ( >>| )
+let ( and+ ) a b = And (a, b)
+let map t ~f = t >>| f
+let try_ t f = Try (t, f)
+let get key = Get key
+let get_all = Get_all
+let set k v t = Set (k, v, t)
+let update_var k ~f t = Update_var (k, f, t)
+let set_many m t = Set_many (m, t)
+let loc = Loc
+let eos = Eos
+let repeat t = Repeat t
+let capture = Capture
+let field_o name ?on_dup t = Field_opt { name; on_dup; t }
+let fields t = Fields_parser t
+let traverse l ~f = Traverse (l, f)
+
+let end_of_list : type a. values context -> a =
+  fun (Values (loc, cstr, _)) ->
   match cstr with
   | None ->
     let loc = Loc.set_start_to_stop loc in
     User_error.raise ~loc [ Pp.text "Premature end of list" ]
   | Some s -> User_error.raise ~loc [ Pp.textf "Not enough arguments for %S" s ]
+;;
+
+let loc_between_states : type k. k context -> k -> k -> Loc.t =
+  let rec search ctx state2 loc last l =
+    if l == state2
+    then Loc.set_stop loc (Ast.loc last |> Loc.stop)
+    else (
+      match l with
+      | [] ->
+        let (Values (loc', _, _)) = ctx in
+        Loc.set_stop loc (Loc.stop loc')
+      | sexp :: rest -> search ctx state2 loc sexp rest)
+  in
+  fun ctx state1 state2 ->
+    match ctx with
+    | Values _ ->
+      (match state1 with
+       | sexp :: rest when rest == state2 ->
+         (* common case *)
+         Ast.loc sexp
+       | [] ->
+         let (Values (loc, _, _)) = ctx in
+         Loc.set_start_to_stop loc
+       | sexp :: rest ->
+         let loc = Ast.loc sexp in
+         search ctx state2 loc sexp rest)
+    | Fields _ ->
+      let parsed =
+        Name.Map.merge state1.unparsed state2.unparsed ~f:(fun _key before after ->
+          match before, after with
+          | Some _, None -> before
+          | _ -> None)
+      in
+      (match
+         Name.Map.to_list_map parsed ~f:(fun _ f -> Ast.loc f.entry)
+         |> List.sort ~compare:loc_compare_start_pos_cnum
+       with
+       | [] ->
+         let (Fields (loc, _, _)) = ctx in
+         loc
+       | first :: l ->
+         let last = List.fold_left l ~init:first ~f:(fun _ x -> x) in
+         Loc.set_stop first (Loc.stop last))
+;;
+
+(* Polymorphic record to allow polymorphic recursion with GADTs *)
+type eval_fn = { f : 'a 'k. ('a, 'k) parser -> 'k context -> 'k -> 'a * 'k }
+
+let field_missing ?hints loc name =
+  User_error.raise ~loc ?hints [ Pp.textf "Field %S is missing" name ]
 [@@inline never] [@@specialise never] [@@local never]
 ;;
 
-let next f ctx sexps =
-  match sexps with
-  | [] -> end_of_list ctx
-  | sexp :: sexps -> f sexp, sexps
-[@@inline always]
+let field_present_too_many_times _ name entries =
+  match entries with
+  | _ :: second :: _ ->
+    User_error.raise
+      ~loc:(Ast.loc second)
+      [ Pp.textf "Field %S is present too many times" name ]
+  | _ -> assert false
 ;;
 
-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 multiple_occurrences =
+  let rec collect acc (x : Fields.Unparsed.t) =
+    let acc = x.entry :: acc in
+    match x.prev with
+    | None -> acc
+    | Some prev -> collect acc prev
+  in
+  fun ?(on_dup = field_present_too_many_times) uc name last ->
+    on_dup uc name (collect [] last)
 ;;
 
-let peek _ctx sexps =
-  match sexps with
-  | [] -> None, sexps
-  | sexp :: _ -> Some sexp, sexps
-[@@inline always]
+let find_single ?on_dup uc (state : Fields.t) name =
+  let res = Name.Map.find state.unparsed name in
+  (match res with
+   | Some ({ prev = Some _; _ } as last) -> multiple_occurrences uc name last ?on_dup
+   | _ -> ());
+  res
 ;;
 
-let peek_exn ctx sexps =
-  match sexps with
+let fields_missing_need_exactly_one loc names =
+  User_error.raise
+    ~loc
+    [ Pp.textf
+        "fields %s are all missing (exactly one is needed)"
+        (String.concat ~sep:", " names)
+    ]
+[@@inline never] [@@specialise never] [@@local never]
+;;
+
+let fields_mutual_exclusion_violation loc names =
+  let names = List.map names ~f:String.quoted in
+  User_error.raise
+    ~loc
+    [ Pp.textf "fields %s are mutually exclusive." (String.enumerate_and names) ]
+[@@inline never] [@@specialise never] [@@local never]
+;;
+
+let rec eval_rec : eval_fn = { f = eval }
+
+and eval : type a k. (a, k) parser -> k context -> k -> a * k =
+  fun desc ctx state ->
+  match desc with
+  | Return x -> x, state
+  | Bind (p, f) ->
+    let x, state = eval p ctx state in
+    eval (f x) ctx state
+  | Map (p, f) ->
+    let x, state = eval p ctx state in
+    f x, state
+  | Seq (p1, p2) ->
+    let (), state = eval p1 ctx state in
+    eval p2 ctx state
+  | And (p1, p2) ->
+    let x, state = eval p1 ctx state in
+    let y, state = eval p2 ctx state in
+    (x, y), state
+  | Try (t, f) ->
+    (try eval t ctx state with
+     | exn -> eval (f exn) ctx state)
+  | Get key -> Univ_map.find (get_user_context ctx) key, state
+  | Get_all -> get_user_context ctx, state
+  | Set (key, v, t) ->
+    (match ctx with
+     | Values (loc, cstr, uc) -> eval t (Values (loc, cstr, Univ_map.set uc key v)) state
+     | Fields (loc, cstr, uc) -> eval t (Fields (loc, cstr, Univ_map.set uc key v)) state)
+  | Update_var (key, f, t) ->
+    (match ctx with
+     | Values (loc, cstr, uc) ->
+       eval t (Values (loc, cstr, Univ_map.update uc key ~f)) state
+     | Fields (loc, cstr, uc) ->
+       eval t (Fields (loc, cstr, Univ_map.update uc key ~f)) state)
+  | Set_many (map, t) ->
+    (match ctx with
+     | Values (loc, cstr, uc) ->
+       eval t (Values (loc, cstr, Univ_map.superpose map uc)) state
+     | Fields (loc, cstr, uc) ->
+       eval t (Fields (loc, cstr, Univ_map.superpose map uc)) state)
+  | Loc ->
+    ( (match ctx with
+       | Values (loc, _, _) -> loc
+       | Fields (loc, _, _) -> loc)
+    , state )
+  | Eos ->
+    ( (match ctx with
+       | Values _ -> state = []
+       | Fields _ -> Name.Map.is_empty state.unparsed)
+    , state )
+  | Repeat t -> eval_repeat t [] ctx state
+  | Capture ->
+    let f t = result ctx (eval t ctx state) in
+    f, []
+  | Next f ->
+    (match state with
+     | [] -> end_of_list ctx
+     | sexp :: sexps -> f sexp, sexps)
+  | Enter t -> eval_enter t ctx state
+  | Peek ->
+    (match state with
+     | [] -> None, state
+     | sexp :: _ -> Some sexp, state)
+  | Peek_exn ->
+    (match state with
+     | [] -> end_of_list ctx
+     | sexp :: _ -> sexp, state)
+  | Junk_everything ->
+    (match ctx with
+     | Values _ -> (), []
+     | Fields _ -> (), Fields.junk_unparsed state)
+  | Keyword kwd -> keyword kwd ctx state
+  | Either (a, b) -> eval_either a b ctx state
+  | Located t ->
+    let x, state2 = eval t ctx state in
+    (loc_between_states ctx state state2, x), state2
+  | Sum { force_parens; cstrs } -> sum ~force_parens cstrs ctx state
+  | Enum cstrs -> enum cstrs ctx state
+  | Field { name; default; on_dup; t } ->
+    let (Fields (loc, _, uc)) = ctx in
+    (match find_single uc state name ?on_dup with
+     | Some { values; entry; _ } ->
+       let ctx = Values (Ast.loc entry, Some name, uc) in
+       let x = result ctx (eval t ctx values) in
+       x, Fields.consume state name
+     | None ->
+       (match default with
+        | Some v -> v, Fields.add_known state name
+        | None -> field_missing loc name))
+  | Field_opt { name; on_dup; t } ->
+    let (Fields (_, _, uc)) = ctx in
+    (match find_single uc state name ?on_dup with
+     | Some { values; entry; _ } ->
+       let ctx = Values (Ast.loc entry, Some name, uc) in
+       let x = result ctx (eval t ctx values) in
+       Some x, Fields.consume state name
+     | None -> None, Fields.add_known state name)
+  | Multi_field { name; t } -> eval_multi_field name t ctx state
+  | Fields_parser t ->
+    let (Values (loc, cstr, uc)) = ctx in
+    let x =
+      let ctx = Fields (loc, cstr, uc) in
+      result ctx (eval t ctx (Fields.of_values state))
+    in
+    x, []
+  | Leftover_fields_generic { names = more_fields; t } ->
+    leftover_fields more_fields t ctx state
+  | Traverse (l, f) -> eval_traverse l f ctx state
+  | Map_validate (t, f) ->
+    let x, state2 = eval t ctx state in
+    (match f x with
+     | Result.Ok x -> x, state2
+     | Error (msg : User_message.t) ->
+       let msg =
+         match msg.loc with
+         | Some _ -> msg
+         | None -> { msg with loc = Some (loc_between_states ctx state state2) }
+       in
+       raise (User_error.E msg))
+  | Kind ->
+    ( (match ctx with
+       | Values (loc, cstr, _) -> Kind.Values (loc, cstr)
+       | Fields (loc, cstr, _) -> Fields (loc, cstr))
+    , state )
+  | Leftover_fields ->
+    leftover_fields (Name.Map.keys state.unparsed) (Next Fun.id) ctx state
+  | Fields_mutually_exclusive { on_dup; default; fields } ->
+    fields_mutually_exclusive ~on_dup ~default ~fields ctx state
+  | Lazy p -> eval (Lazy.force p) ctx state
+  | Fix f ->
+    let rec p = lazy (f r)
+    and r = Lazy p in
+    eval r ctx state
+
+and eval_enter : type a. a t -> values context -> values -> a * values =
+  fun t (Values (_, _, uc) as ctx) state ->
+  match state with
+  | [] -> end_of_list ctx
+  | sexp :: sexps ->
+    let res =
+      match sexp with
+      | List (loc, l) ->
+        let ctx = Values (loc, None, uc) in
+        result ctx (eval t ctx l)
+      | sexp -> User_error.raise ~loc:(Ast.loc sexp) [ Pp.text "List expected" ]
+    in
+    res, sexps
+
+and leftover_fields
+  : type a. string list -> a t -> fields context -> fields -> a list * fields
+  =
+  fun more_fields t (Fields (loc, cstr, uc)) state ->
+  let x =
+    let ctx = Values (loc, cstr, uc) in
+    result ctx (eval_repeat t [] ctx (Fields.unparsed_ast state))
+  in
+  x, Fields.leftover_fields state more_fields
+
+and eval_traverse
+  : type a b c. a list -> (a -> (b, c) parser) -> c context -> c -> b list * c
+  =
+  fun l f ctx state ->
+  List.fold_map ~init:state l ~f:(fun state x -> Tuple.T2.swap (eval (f x) ctx state))
+  |> Tuple.T2.swap
+
+and fields_mutually_exclusive
+  : type a.
+    on_dup:(Univ_map.t -> string -> Ast.t list -> unit) option
+    -> default:a option
+    -> fields:(string * a t) list
+    -> fields context
+    -> fields
+    -> a * fields
+  =
+  fun ~on_dup ~default ~fields ((Fields (loc, _, _) : _ context) as ctx) state ->
+  let res, state =
+    eval_traverse
+      fields
+      (fun (name, parser) -> field_o name ?on_dup parser >>| fun res -> name, res)
+      ctx
+      state
+  in
+  match
+    List.filter_map res ~f:(function
+      | name, Some x -> Some (name, x)
+      | _, None -> None)
+  with
+  | [] ->
+    (match default with
+     | None -> List.map fields ~f:fst |> fields_missing_need_exactly_one loc
+     | Some default -> default, state)
+  | [ (_name, res) ] -> res, state
+  | _ :: _ :: _ as results ->
+    List.map ~f:fst results |> fields_mutual_exclusion_violation loc
+
+and eval_repeat : type a. a t -> a list -> values context -> values -> a list * values =
+  fun t acc ctx state ->
+  match state with
+  | [] -> List.rev acc, []
+  | _ ->
+    let x, state = eval t ctx state in
+    eval_repeat t (x :: acc) ctx state
+
+(* Before you read this code, close your eyes and internalise the fact that
+   this code is temporary. It is a temporary state as part of a larger work to
+   turn [Decoder.t] into a pure applicative. Once this is done, this function
+   will be implemented in a better way and with a much cleaner semantic. *)
+and eval_either
+  : type a b k. (a, k) parser -> (b, k) parser -> k context -> k -> (a, b) either * k
+  =
+  let approximate_how_much_input_a_failing_branch_consumed (exn : Exn_with_backtrace.t) =
+    Printexc.raw_backtrace_length exn.backtrace
+  in
+  let compare_input_consumed exn1 exn2 =
+    Int.compare
+      (approximate_how_much_input_a_failing_branch_consumed exn1)
+      (approximate_how_much_input_a_failing_branch_consumed exn2)
+  in
+  fun a b ctx state ->
+    try eval_rec.f (Map (a, Either.left)) ctx state with
+    | exn_a ->
+      let exn_a = Exn_with_backtrace.capture exn_a in
+      (try eval_rec.f (Map (b, Either.right)) ctx state with
+       | exn_b ->
+         let exn_b = Exn_with_backtrace.capture exn_b in
+         Exn_with_backtrace.reraise
+           (match compare_input_consumed exn_a exn_b with
+            | Gt -> exn_a
+            | Eq | Lt -> exn_b))
+
+and find_cstr
+  : type a. (string * a t) list -> Loc.t -> string -> values context -> values -> a
+  =
+  fun cstrs loc name ctx values ->
+  match List.assoc cstrs name with
+  | Some t -> result ctx (eval t ctx values)
+  | None ->
+    User_error.raise
+      ~loc
+      ~hints:(User_message.did_you_mean name ~candidates:(List.map cstrs ~f:fst))
+      [ Pp.textf "Unknown constructor %s" name ]
+
+and sum
+  : type a.
+    force_parens:bool
+    -> (string * (a, values) parser) list
+    -> values context
+    -> values
+    -> a * values
+  =
+  fun ~force_parens cstrs (Values (_, _, uc) as ctx) (state : Ast.t list) ->
+  match state with
+  | [] -> end_of_list ctx
+  | sexp :: sexps ->
+    let res =
+      match sexp with
+      | Atom (loc, A s) when not force_parens ->
+        find_cstr cstrs loc s (Values (loc, Some s, uc)) []
+      | Atom (loc, _) | Template { loc; _ } | Quoted_string (loc, _) | List (loc, []) ->
+        User_error.raise
+          ~loc
+          [ Pp.textf
+              "S-expression of the form %s expected"
+              (if force_parens then "(<atom> ...)" else "(<atom> ...) or <atom>")
+          ]
+      | List (loc, name :: args) ->
+        (match name with
+         | Quoted_string (loc, _) | List (loc, _) | Template { loc; _ } ->
+           User_error.raise ~loc [ Pp.text "Atom expected" ]
+         | Atom (s_loc, A s) -> find_cstr cstrs s_loc s (Values (loc, Some s, uc)) args)
+    in
+    res, sexps
+
+and enum
+  : type a. (string * (a, values) parser) list -> values context -> values -> a * values
+  =
+  fun cstrs (Values (_, _, uc) as ctx) (state : Ast.t list) ->
+  match state with
+  | [] -> end_of_list ctx
+  | sexp :: sexps ->
+    let res =
+      match sexp with
+      | Quoted_string (loc, _) | Template { loc; _ } | List (loc, _) ->
+        User_error.raise ~loc [ Pp.text "Atom expected" ]
+      | Atom (loc, A s) ->
+        (match List.assoc cstrs s with
+         | Some k ->
+           let ctx = Values (loc, Some s, uc) in
+           result ctx (eval k ctx [])
+         | None ->
+           User_error.raise
+             ~loc
+             [ Pp.textf "Unknown value %s" s ]
+             ~hints:(User_message.did_you_mean s ~candidates:(List.map cstrs ~f:fst)))
+    in
+    res, sexps
+
+and eval_multi_field
+  : type a. string -> (a, values) parser -> fields context -> fields -> a list * fields
+  =
+  let rec loop t uc name acc (field : Fields.Unparsed.t option) =
+    match field with
+    | None -> acc
+    | Some { values; prev; entry } ->
+      let x =
+        let ctx = Values (Ast.loc entry, Some name, uc) in
+        result ctx (eval t ctx values)
+      in
+      loop t uc name (x :: acc) prev
+  in
+  fun name t (Fields (_, _, uc)) (state : Fields.t) ->
+    let res = loop t uc name [] (Name.Map.find state.unparsed name) in
+    res, Fields.consume state name
+
+and keyword : string -> values context -> values -> unit * values =
+  fun kwd ctx state ->
+  match state with
   | [] -> end_of_list ctx
-  | sexp :: _ -> sexp, sexps
-[@@inline always]
+  | sexp :: sexps ->
+    let () =
+      match sexp with
+      | Atom (_, A s) when s = kwd -> ()
+      | sexp -> User_error.raise ~loc:(Ast.loc sexp) [ Pp.textf "'%s' expected" kwd ]
+    in
+    (* Silly that we need to create this tuple *)
+    (), sexps
 ;;
 
-let junk = next ignore
+let repeat1 p =
+  let+ x = p
+  and+ xs = repeat p in
+  x :: xs
+;;
 
-let junk_everything : type k. (unit, k) parser =
-  fun ctx state ->
-  match ctx with
-  | Values _ -> (), []
-  | Fields _ -> (), Fields.junk_unparsed state
+let parse t context sexp =
+  let ctx = Values (Ast.loc sexp, None, context) in
+  result ctx (eval t ctx [ sexp ])
 ;;
 
-let keyword kwd =
-  next (function
-    | Atom (_, A s) when s = kwd -> ()
-    | sexp -> User_error.raise ~loc:(Ast.loc sexp) [ Pp.textf "'%s' expected" kwd ])
+let lazy_ t =
+  let+ f = capture in
+  lazy (f t)
 ;;
 
+let next f = Next f
+let peek = Peek
+let peek_exn = Peek_exn
+let junk = next ignore
+let junk_everything = Junk_everything
+let keyword kwd = Keyword kwd
+
 let atom_matching f ~desc =
   next (fun sexp ->
     match
@@ -364,40 +762,8 @@ let relative_file =
     else User_error.raise ~loc [ Pp.textf "relative filename expected" ])
 ;;
 
-let enter t =
-  next_with_user_context (fun uc sexp ->
-    match sexp with
-    | List (loc, l) ->
-      let ctx = Values (loc, None, uc) in
-      result ctx (t ctx l)
-    | sexp -> User_error.raise ~loc:(Ast.loc sexp) [ Pp.text "List expected" ])
-;;
-
-let either =
-  (* Before you read this code, close your eyes and internalise the fact that
-     this code is temporary. It is a temporary state as part of a larger work to
-     turn [Decoder.t] into a pure applicative. Once this is done, this function
-     will be implemented in a better way and with a much cleaner semantic. *)
-  let approximate_how_much_input_a_failing_branch_consumed (exn : Exn_with_backtrace.t) =
-    Printexc.raw_backtrace_length exn.backtrace
-  in
-  let compare_input_consumed exn1 exn2 =
-    Int.compare
-      (approximate_how_much_input_a_failing_branch_consumed exn1)
-      (approximate_how_much_input_a_failing_branch_consumed exn2)
-  in
-  fun a b ctx state ->
-    try (a >>| Either.left) ctx state with
-    | exn_a ->
-      let exn_a = Exn_with_backtrace.capture exn_a in
-      (try (b >>| Either.right) ctx state with
-       | exn_b ->
-         let exn_b = Exn_with_backtrace.capture exn_b in
-         Exn_with_backtrace.reraise
-           (match compare_input_consumed exn_a exn_b with
-            | Gt -> exn_a
-            | Eq | Lt -> exn_b))
-;;
+let enter t = Enter t
+let either l r = Either (l, r)
 
 let ( <|> ) x y =
   either x y
@@ -406,60 +772,8 @@ let ( <|> ) x y =
   | Right x -> x
 ;;
 
-let fix f =
-  let rec p = lazy (f r)
-  and r ast = (Lazy.force p) ast in
-  r
-;;
-
-let loc_between_states : type k. k context -> k -> k -> Loc.t =
-  let rec search ctx state2 loc last l =
-    if l == state2
-    then Loc.set_stop loc (Ast.loc last |> Loc.stop)
-    else (
-      match l with
-      | [] ->
-        let (Values (loc', _, _)) = ctx in
-        Loc.set_stop loc (Loc.stop loc')
-      | sexp :: rest -> search ctx state2 loc sexp rest)
-  in
-  fun ctx state1 state2 ->
-    match ctx with
-    | Values _ ->
-      (match state1 with
-       | sexp :: rest when rest == state2 ->
-         (* common case *)
-         Ast.loc sexp
-       | [] ->
-         let (Values (loc, _, _)) = ctx in
-         Loc.set_start_to_stop loc
-       | sexp :: rest ->
-         let loc = Ast.loc sexp in
-         search ctx state2 loc sexp rest)
-    | Fields _ ->
-      let parsed =
-        Name.Map.merge state1.unparsed state2.unparsed ~f:(fun _key before after ->
-          match before, after with
-          | Some _, None -> before
-          | _ -> None)
-      in
-      (match
-         Name.Map.to_list_map parsed ~f:(fun _ f -> Ast.loc f.entry)
-         |> List.sort ~compare:loc_compare_start_pos_cnum
-       with
-       | [] ->
-         let (Fields (loc, _, _)) = ctx in
-         loc
-       | first :: l ->
-         let last = List.fold_left l ~init:first ~f:(fun _ x -> x) in
-         Loc.set_stop first (Loc.stop last))
-;;
-
-let located t ctx state1 =
-  let x, state2 = t ctx state1 in
-  (loc_between_states ctx state1 state2, x), state2
-;;
-
+let fix f = Fix f
+let located t = Located t
 let raw = next Fun.id
 
 let basic_loc desc f =
@@ -521,122 +835,12 @@ let unit_number_int64 =
 let duration = unit_number "Duration" [ [ "s" ], 1; [ "m" ], 60; [ "h" ], 60 * 60 ]
 let bytes_unit = unit_number_int64 "Byte amount" Bytes_unit.conversion_table
 let maybe t = t >>| Option.some <|> return None
-
-let find_cstr cstrs loc name ctx values =
-  match List.assoc cstrs name with
-  | Some t -> result ctx (t ctx values)
-  | None ->
-    User_error.raise
-      ~loc
-      ~hints:(User_message.did_you_mean name ~candidates:(List.map cstrs ~f:fst))
-      [ Pp.textf "Unknown constructor %s" name ]
-;;
-
-let sum ?(force_parens = false) cstrs =
-  next_with_user_context (fun uc sexp ->
-    match sexp with
-    | Atom (loc, A s) when not force_parens ->
-      find_cstr cstrs loc s (Values (loc, Some s, uc)) []
-    | Atom (loc, _) | Template { loc; _ } | Quoted_string (loc, _) | List (loc, []) ->
-      User_error.raise
-        ~loc
-        [ Pp.textf
-            "S-expression of the form %s expected"
-            (if force_parens then "(<atom> ...)" else "(<atom> ...) or <atom>")
-        ]
-    | List (loc, name :: args) ->
-      (match name with
-       | Quoted_string (loc, _) | List (loc, _) | Template { loc; _ } ->
-         User_error.raise ~loc [ Pp.text "Atom expected" ]
-       | Atom (s_loc, A s) -> find_cstr cstrs s_loc s (Values (loc, Some s, uc)) args))
-;;
-
-let enum' (type a) (cstrs : (string * a t) list) : a t =
-  next_with_user_context (fun uc sexp ->
-    match sexp with
-    | Quoted_string (loc, _) | Template { loc; _ } | List (loc, _) ->
-      User_error.raise ~loc [ Pp.text "Atom expected" ]
-    | Atom (loc, A s) ->
-      (match List.assoc cstrs s with
-       | Some k ->
-         let ctx = Values (loc, Some s, uc) in
-         result ctx (k ctx [])
-       | None ->
-         User_error.raise
-           ~loc
-           [ Pp.textf "Unknown value %s" s ]
-           ~hints:(User_message.did_you_mean s ~candidates:(List.map cstrs ~f:fst))))
-;;
-
+let sum ?(force_parens = false) cstrs = Sum { force_parens; cstrs }
+let enum' cstrs = Enum cstrs
 let enum cstrs = enum' (List.map cstrs ~f:(fun (name, v) -> name, return v))
 let bool = enum [ "true", true; "false", false ]
-
-let map_validate t ~f ctx state1 =
-  let x, state2 = t ctx state1 in
-  match f x with
-  | Result.Ok x -> x, state2
-  | Error (msg : User_message.t) ->
-    let msg =
-      match msg.loc with
-      | Some _ -> msg
-      | None -> { msg with loc = Some (loc_between_states ctx state1 state2) }
-    in
-    raise (User_error.E msg)
-;;
-
-let field_missing ?hints loc name =
-  User_error.raise ~loc ?hints [ Pp.textf "Field %S is missing" name ]
-[@@inline never] [@@specialise never] [@@local never]
-;;
-
-let field_present_too_many_times _ name entries =
-  match entries with
-  | _ :: second :: _ ->
-    User_error.raise
-      ~loc:(Ast.loc second)
-      [ Pp.textf "Field %S is present too many times" name ]
-  | _ -> assert false
-;;
-
-let multiple_occurrences =
-  let rec collect acc (x : Fields.Unparsed.t) =
-    let acc = x.entry :: acc in
-    match x.prev with
-    | None -> acc
-    | Some prev -> collect acc prev
-  in
-  fun ?(on_dup = field_present_too_many_times) uc name last ->
-    on_dup uc name (collect [] last)
-;;
-
-let find_single ?on_dup uc (state : Fields.t) name =
-  let res = Name.Map.find state.unparsed name in
-  (match res with
-   | Some ({ prev = Some _; _ } as last) -> multiple_occurrences uc name last ?on_dup
-   | _ -> ());
-  res
-;;
-
-let field name ?default ?on_dup t (Fields (loc, _, uc)) state =
-  match find_single uc state name ?on_dup with
-  | Some { values; entry; _ } ->
-    let ctx = Values (Ast.loc entry, Some name, uc) in
-    let x = result ctx (t ctx values) in
-    x, Fields.consume state name
-  | None ->
-    (match default with
-     | Some v -> v, Fields.add_known state name
-     | None -> field_missing loc name)
-;;
-
-let field_o name ?on_dup t (Fields (_, _, uc)) state =
-  match find_single uc state name ?on_dup with
-  | Some { values; entry; _ } ->
-    let ctx = Values (Ast.loc entry, Some name, uc) in
-    let x = result ctx (t ctx values) in
-    Some x, Fields.consume state name
-  | None -> None, Fields.add_known state name
-;;
+let map_validate t ~f = Map_validate (t, f)
+let field name ?default ?on_dup t = Field { name; default; on_dup; t }
 
 let field_b_gen field_gen ?check ?on_dup name =
   field_gen
@@ -651,105 +855,21 @@ let field_b_gen field_gen ?check ?on_dup name =
 
 let field_b = field_b_gen (field ~default:false)
 let field_o_b = field_b_gen field_o
+let multi_field name t = Multi_field { name; t }
 
-let multi_field =
-  let rec loop t uc name acc (field : Fields.Unparsed.t option) =
-    match field with
-    | None -> acc
-    | Some { values; prev; entry } ->
-      let ctx = Values (Ast.loc entry, Some name, uc) in
-      let x = result ctx (t ctx values) in
-      loop t uc name (x :: acc) prev
-  in
-  fun name t (Fields (_, _, uc)) (state : Fields.t) ->
-    let res = loop t uc name [] (Name.Map.find state.unparsed name) in
-    res, Fields.consume state name
-;;
-
-let fields t (Values (loc, cstr, uc)) sexps =
-  let ctx = Fields (loc, cstr, uc) in
-  let x = result ctx (t ctx (Fields.of_values sexps)) in
-  x, []
-;;
-
-let leftover_fields_generic t more_fields (Fields (loc, cstr, uc)) state =
-  let x =
-    let ctx = Values (loc, cstr, uc) in
-    result ctx (repeat t ctx (Fields.unparsed_ast state))
-  in
-  x, Fields.leftover_fields state more_fields
+let leftover_fields_generic t more_fields =
+  Leftover_fields_generic { t; names = more_fields }
 ;;
 
-let leftover_fields ctx (state : Fields.t) =
-  leftover_fields_generic raw (Name.Map.keys state.unparsed) ctx state
-;;
+let leftover_fields : (Ast.t list, Fields.t) parser = Leftover_fields
 
 let leftover_fields_as_sums cstrs =
   leftover_fields_generic (sum cstrs) (List.map cstrs ~f:fst)
 ;;
 
-type kind =
-  | Values of Loc.t * string option
-  | Fields of Loc.t * string option
-
-let kind : type k. k context -> k -> kind * k =
-  fun ctx state ->
-  match ctx with
-  | Values (loc, cstr, _) -> Values (loc, cstr), state
-  | Fields (loc, cstr, _) -> Fields (loc, cstr), state
-;;
-
-let traverse l ~f ctx state =
-  Tuple.T2.swap
-    (List.fold_map ~init:state l ~f:(fun state x -> Tuple.T2.swap (f x ctx state)))
-;;
-
-let all = traverse ~f:Fun.id
-
-let fields_missing_need_exactly_one loc names =
-  User_error.raise
-    ~loc
-    [ Pp.textf
-        "fields %s are all missing (exactly one is needed)"
-        (String.concat ~sep:", " names)
-    ]
-[@@inline never] [@@specialise never] [@@local never]
-;;
-
-let fields_mutual_exclusion_violation loc names =
-  let names = List.map names ~f:String.quoted in
-  User_error.raise
-    ~loc
-    [ Pp.textf "fields %s are mutually exclusive." (String.enumerate_and names) ]
-[@@inline never] [@@specialise never] [@@local never]
-;;
+let kind : type k. (Kind.t, k) parser = Kind
+let all l = traverse l ~f:Fun.id
 
-let fields_mutually_exclusive
-      ?on_dup
-      ?default
-      fields
-      ((Fields (loc, _, _) : _ context) as ctx)
-      state
-  =
-  let res, state =
-    traverse
-      ~f:(fun (name, parser) -> field_o name ?on_dup parser >>| fun res -> name, res)
-      fields
-      ctx
-      state
-  in
-  match
-    List.filter_map res ~f:(function
-      | name, Some x -> Some (name, x)
-      | _, None -> None)
-  with
-  | [] ->
-    let names = List.map fields ~f:fst in
-    (match default with
-     | None -> fields_missing_need_exactly_one loc names
-     | Some default -> default, state)
-  | [ (_name, res) ] -> res, state
-  | _ :: _ :: _ as results ->
-    let names = List.map ~f:fst results in
-    fields_mutual_exclusion_violation loc names
+let fields_mutually_exclusive ?on_dup ?default fields =
+  Fields_mutually_exclusive { on_dup; default; fields }
 ;;
diff --git a/src/dune_sexp/decoder.mli b/src/dune_sexp/decoder.mli
index 93d6527b3a4..1eecec82f03 100644
--- a/src/dune_sexp/decoder.mli
+++ b/src/dune_sexp/decoder.mli
@@ -122,16 +122,18 @@ val keyword : string -> unit t
     [after] to parse the rest. *)
 val until_keyword : string -> before:'a t -> after:'b t -> ('a list * 'b option) t
 
-(** What is currently being parsed. The second argument is the atom at the
-    beginning of the list when inside a [sum ...] or [field ...]. *)
-type kind =
-  | Values of Loc.t * string option
-  | Fields of Loc.t * string option
+module Kind : sig
+  (** What is currently being parsed. The second argument is the atom at the
+      beginning of the list when inside a [sum ...] or [field ...]. *)
+  type t =
+    | Values of Loc.t * string option
+    | Fields of Loc.t * string option
+end
 
 (** [kind] returns the current kind of the parser, whether it is parsing a list
     of values or a list of fields, together with the atom at the beginning of
     a list when inside [sum ...] or [field ...]. *)
-val kind : (kind, _) parser
+val kind : (Kind.t, _) parser
 
 (** [repeat t] uses [t] to consume all remaining elements of the input until the
     end of sequence is reached. *)