Normalise shared field prefixes at underscore boundaries

record.ml

@@ -52,3 +52,20 @@ let () =
   assert (view focus changed = 8 && Swatch.label changed = "grey");
   assert (set focus (view focus original) original = original);
   assert (set Box._contents "grey" Box.{ contents = 9 } = Box.{ contents = "grey" })
+
+module Prefixed = struct
+  type t = { paint_colour_red : int; paint_colour_green : int } [@@fieldglass generate]
+end
+
+module Unprefixed = struct
+  type t = { yes : bool; yellow : bool } [@@fieldglass generate]
+end
+
+module Single = struct
+  type t = { paint_red : int } [@@fieldglass generate]
+end
+
+let () =
+  assert (Prefixed.red Prefixed.{ paint_colour_red = 3; paint_colour_green = 4 } = 3);
+  assert (Unprefixed.yes Unprefixed.{ yes = true; yellow = false });
+  assert (Single.paint_red Single.{ paint_red = 3 } = 3)

rewrite.ml

@@ -17,6 +17,21 @@ let configured declaration =
   | _ -> Location.raise_errorf ~loc:declaration.ptype_loc
       "fieldglass: expected [@@fieldglass generate]"
 
+let field_names fields =
+  let names = List.map (fun field -> field.pld_name.txt) fields in
+  match names with
+  | [] | [_] -> names
+  | first :: rest ->
+      let shared = List.fold_left (fun limit name ->
+        let limit = min limit (String.length name) in
+        let rec compare i =
+          if i < limit && first.[i] = name.[i] then compare (i + 1) else i in
+        compare 0) (String.length first) rest in
+      let rec boundary n =
+        if n = 0 || first.[n - 1] = '_' then n else boundary (n - 1) in
+      let count = boundary shared in
+      List.map (fun name -> String.sub name count (String.length name - count)) names
+
 let generate declaration =
   let loc = declaration.ptype_loc in
   let fields = match declaration.ptype_kind with
@@ -27,7 +42,7 @@ let generate 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
-  List.concat (List.map (fun field ->
+  List.concat (List.map2 (fun field short_name ->
     let name = field.pld_name.txt in
     let getter = lambda ~loc Nolabel source_pattern
         (Exp.field ~loc source (ident ~loc name)) in
@@ -41,8 +56,8 @@ let generate 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])
-      [name, getter; "set_" ^ name, setter; "update_" ^ name, updater;
-       "_" ^ name, Exp.tuple ~loc [getter; setter]]) fields)
+      [short_name, getter; "set_" ^ short_name, setter; "update_" ^ short_name, updater;
+       "_" ^ short_name, Exp.tuple ~loc [getter; setter]]) fields (field_names fields))
 
 let structure mapper items =
   List.concat (List.map (fun item ->