From 65114446e08a74276b69d7790b27a9aa179f84d2 Mon Sep 17 00:00:00 2001
From: milner <m@cpl0.zip>
Date: Sat, 30 Mar 2019 13:59:36 +0000
Subject: [PATCH] Customise getter, setter, and updater names independently

---
 record.ml  | 12 ++++++++++++
 rewrite.ml | 21 ++++++++++++++++-----
 2 files changed, 28 insertions(+), 5 deletions(-)

diff --git a/record.ml b/record.ml
index 7d2ff01..795fba1 100644
--- a/record.ml
+++ b/record.ml
@@ -83,3 +83,15 @@ end
 let () =
   assert (Named.swatch_colour Named.{ item_colour = "grey"; item_size = 3 } = "grey");
   assert (Typed.swatch_size Typed.{ item_colour = "grey"; item_size = 3 } = 3)
+
+module Verbs = struct
+  type t = { colour : string }
+    [@@fieldglass generate ~get_prefix:read ~set_prefix:replace ~update_prefix:"revise"]
+end
+
+let () =
+  let original = Verbs.{ colour = "grey" } in
+  assert (Verbs.read_colour original = "grey");
+  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")
diff --git a/rewrite.ml b/rewrite.ml
index e18cf3a..8e7145d 100644
--- a/rewrite.ml
+++ b/rewrite.ml
@@ -10,8 +10,14 @@ let lambda ~loc label pattern body = Exp.fun_ ~loc label None pattern body
 let is_marker (name, _) = name.txt = "fieldglass" || name.txt = "lens"
 
 type prefix = Plain | Named of string | Type_name
-type options = { field_prefix : prefix }
-let defaults = { field_prefix = Plain }
+type options = {
+  field_prefix : prefix;
+  get_prefix : string option;
+  set_prefix : string;
+  update_prefix : string;
+}
+let defaults = { field_prefix = Plain; get_prefix = None;
+                 set_prefix = "set"; update_prefix = "update" }
 
 let word expression =
   match expression.pexp_desc with
@@ -30,9 +36,12 @@ let flag name expression =
 
 let configure options (label, expression) =
   match label with
-  | Labelled "field_prefix" -> { field_prefix = Named (word expression) }
+  | Labelled "field_prefix" -> { options with field_prefix = Named (word expression) }
   | Labelled "field_prefix_from_type" ->
-      { field_prefix = if flag "field_prefix_from_type" expression then Type_name else Plain }
+      { options with field_prefix = if flag "field_prefix_from_type" expression then Type_name else Plain }
+  | 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 }
   | _ -> Location.raise_errorf ~loc:expression.pexp_loc
       "fieldglass: unrecognised configuration option"
 
@@ -92,7 +101,9 @@ let generate options declaration =
               [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])
-      [short_name, getter; "set_" ^ short_name, setter; "update_" ^ short_name, updater;
+      [(match options.get_prefix with None -> short_name | Some prefix -> prefix ^ "_" ^ short_name), getter;
+       options.set_prefix ^ "_" ^ short_name, setter;
+       options.update_prefix ^ "_" ^ short_name, updater;
        "_" ^ short_name, Exp.tuple ~loc [getter; setter]]) fields (field_names fields))
 
 let structure mapper items =