From c02ef26bc88e6f776ed6c83334bdd917feb1094f Mon Sep 17 00:00:00 2001
From: milner <m@cpl0.zip>
Date: Fri, 5 Apr 2019 21:27:46 +0000
Subject: [PATCH] Support source-first setters and configurable updater
 arguments

---
 record.ml  | 21 +++++++++++++++++++++
 rewrite.ml | 27 +++++++++++++++++++--------
 2 files changed, 40 insertions(+), 8 deletions(-)

diff --git a/record.ml b/record.ml
index 795fba1..c35e2cb 100644
--- a/record.ml
+++ b/record.ml
@@ -95,3 +95,24 @@ let () =
   assert (Verbs.read_colour (Verbs.replace_colour "blue" original) = "blue");
   assert (Verbs.read_colour (Verbs.revise_colour ~f:(fun s -> s ^ "s") original) = "greys");
   assert (Fieldglass.view Verbs._colour original = "grey")
+
+module Ordered = struct
+  type t = { count : int }
+    [@@fieldglass generate ~self_arg_first ~func_named_arg:change]
+end
+
+module Positional = struct
+  type t = { count : int }
+    [@@fieldglass generate ~self_arg_first ~func_no_named_arg]
+end
+
+module Last = struct
+  type t = { count : int } [@@fieldglass generate ~func_no_named_arg]
+end
+
+let () =
+  assert (Ordered.set_count Ordered.{ count = 1 } 2 = Ordered.{ count = 2 });
+  assert (Ordered.update_count Ordered.{ count = 1 } ~change:succ = Ordered.{ count = 2 });
+  assert (Fieldglass.set Ordered._count 2 Ordered.{ count = 1 } = Ordered.{ count = 2 });
+  assert (Positional.update_count Positional.{ count = 1 } succ = Positional.{ count = 2 });
+  assert (Last.update_count succ Last.{ count = 1 } = Last.{ count = 2 })
diff --git a/rewrite.ml b/rewrite.ml
index 8e7145d..9216062 100644
--- a/rewrite.ml
+++ b/rewrite.ml
@@ -15,9 +15,12 @@ type options = {
   get_prefix : string option;
   set_prefix : string;
   update_prefix : string;
+  self_first : bool;
+  function_label : string option;
 }
 let defaults = { field_prefix = Plain; get_prefix = None;
-                 set_prefix = "set"; update_prefix = "update" }
+                 set_prefix = "set"; update_prefix = "update";
+                 self_first = false; function_label = Some "f" }
 
 let word expression =
   match expression.pexp_desc with
@@ -42,6 +45,10 @@ let configure options (label, expression) =
   | Labelled "get_prefix" -> { options with get_prefix = Some (word expression) }
   | Labelled "set_prefix" -> { options with set_prefix = word expression }
   | Labelled "update_prefix" -> { options with update_prefix = word expression }
+  | Labelled "self_arg_first" -> { options with self_first = flag "self_arg_first" expression }
+  | Labelled "func_named_arg" -> { options with function_label = Some (word expression) }
+  | Labelled "func_no_named_arg" ->
+      { options with function_label = if flag "func_no_named_arg" expression then None else Some "f" }
   | _ -> Location.raise_errorf ~loc:expression.pexp_loc
       "fieldglass: unrecognised configuration option"
 
@@ -83,6 +90,10 @@ let generate options declaration =
   let source_pattern = Pat.constraint_ ~loc (variable ~loc "__fg_source")
       (Typ.constr ~loc (ident ~loc declaration.ptype_name.txt)
          (List.map (fun _ -> Typ.any ~loc ()) declaration.ptype_params)) in
+  let arguments self_first label name body =
+    let self = lambda ~loc Nolabel source_pattern in
+    let other = lambda ~loc label (variable ~loc name) in
+    if self_first then self (other body) else other (self body) in
   List.concat (List.map2 (fun field short_name ->
     let name = field.pld_name.txt in
     let short_name = match options.field_prefix with
@@ -93,18 +104,18 @@ let generate options declaration =
         (Exp.field ~loc source (ident ~loc name)) in
     let replace expression = Exp.record ~loc [ident ~loc name, expression]
         (if List.length fields = 1 then None else Some source) in
-    let setter = lambda ~loc Nolabel (variable ~loc "__fg_value")
-        (lambda ~loc Nolabel source_pattern (replace (value ~loc "__fg_value"))) in
-    let updater = lambda ~loc (Labelled "f") (variable ~loc "__fg_function")
-        (lambda ~loc Nolabel source_pattern
+    let setter self_first = arguments self_first Nolabel "__fg_value"
+        (replace (value ~loc "__fg_value")) in
+    let label = match options.function_label with None -> Nolabel | Some name -> Labelled name in
+    let updater = arguments options.self_first label "__fg_function"
            (replace (Exp.apply ~loc (value ~loc "__fg_function")
-              [Nolabel, Exp.field ~loc source (ident ~loc name)]))) in
+              [Nolabel, Exp.field ~loc source (ident ~loc name)])) in
     List.map (fun (name, body) ->
       Str.value ~loc Nonrecursive [Vb.mk ~loc (variable ~loc name) body])
       [(match options.get_prefix with None -> short_name | Some prefix -> prefix ^ "_" ^ short_name), getter;
-       options.set_prefix ^ "_" ^ short_name, setter;
+       options.set_prefix ^ "_" ^ short_name, setter options.self_first;
        options.update_prefix ^ "_" ^ short_name, updater;
-       "_" ^ short_name, Exp.tuple ~loc [getter; setter]]) fields (field_names fields))
+       "_" ^ short_name, Exp.tuple ~loc [getter; setter false]]) fields (field_names fields))
 
 let structure mapper items =
   List.concat (List.map (fun item ->