Disambiguate recursive record groups and share group configuration

record.ml

@@ -133,3 +133,24 @@ let () =
   assert (Fieldglass.view Pairs._colour Pairs.{ colour = "grey" } = "grey");
   assert (Silent.{ colour = "grey" }.colour = "grey");
   assert (Functions.colour Functions.{ colour = "grey" } = "grey")
+
+module Recursive = struct
+  type left = { value : int; next : right option }
+  and right = { value : string; next : left option }
+    [@@fieldglass generate ~field_prefix_from_type]
+end
+
+module Ambiguous = struct
+  type number = { contents : int }
+  and text = { contents : string }
+    [@@fieldglass generate ~field_prefix_from_type]
+end
+
+let () =
+  let left : Recursive.left = { value = 3; next = None } in
+  let right : Recursive.right = { value = "grey"; next = Some left } in
+  assert (Recursive.left_value left = 3);
+  assert (Recursive.right_value (Recursive.set_right_value "blue" right) = "blue");
+  assert (Recursive.right_next right = Some left);
+  let number : Ambiguous.number = { contents = 3 } in
+  assert (Ambiguous.number_contents (Ambiguous.set_number_contents 4 number) = 4)

rewrite.ml

@@ -73,7 +73,7 @@ let configured declaration =
         | Pexp_apply ({ pexp_desc = Pexp_ident { txt = Longident.Lident "generate"; _ }; _ }, arguments) -> arguments
         | _ -> Location.raise_errorf ~loc:expression.pexp_loc
             "fieldglass: expected generate followed by labelled options" in
-      Some (List.fold_left configure defaults arguments)
+      Some arguments
   | _ -> Location.raise_errorf ~loc:declaration.ptype_loc
       "fieldglass: expected [@@fieldglass generate]"
 
@@ -99,9 +99,10 @@ let generate options declaration =
     | _ -> Location.raise_errorf ~loc "fieldglass: expected a record type"
   in
   let source = value ~loc "__fg_source" in
+  let record_type () = Typ.constr ~loc (ident ~loc declaration.ptype_name.txt)
+      (List.map (fun _ -> Typ.any ~loc ()) declaration.ptype_params) in
   let source_pattern = Pat.constraint_ ~loc (variable ~loc "__fg_source")
-      (Typ.constr ~loc (ident ~loc declaration.ptype_name.txt)
+      (record_type ()) in
-         (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
@@ -114,8 +115,9 @@ let generate options declaration =
       | Type_name -> declaration.ptype_name.txt ^ "_" ^ short_name in
     let getter = lambda ~loc Nolabel source_pattern
         (Exp.field ~loc source (ident ~loc name)) in
-    let replace expression = Exp.record ~loc [ident ~loc name, expression]
+    let replace expression = Exp.constraint_ ~loc
-        (if List.length fields = 1 then None else Some source) in
+        (Exp.record ~loc [ident ~loc name, expression]
+           (if List.length fields = 1 then None else Some source)) (record_type ()) in
     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
@@ -134,10 +136,13 @@ let structure mapper items =
     let item = Ast_mapper.default_mapper.structure_item mapper item in
     match item.pstr_desc with
     | Pstr_type (recursive, declarations) ->
-        let generated = List.concat (List.map (fun declaration ->
+        let configurations = List.map configured declarations in
-          match configured declaration with
+        let generated =
-          | Some options -> generate options declaration
+          if List.exists (function Some _ -> true | None -> false) configurations then
-          | None -> []) declarations) in
+            let arguments = List.concat (List.map (function Some args -> args | None -> []) configurations) in
+            let options = List.fold_left configure defaults arguments in
+            List.concat (List.map (generate options) declarations)
+          else [] in
         let declarations = List.map (fun declaration ->
           { declaration with ptype_attributes =
               List.filter (fun attribute -> not (is_marker attribute)) declaration.ptype_attributes }) declarations in