Disambiguate recursive record groups and share group configuration

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)
-         (List.map (fun _ -> Typ.any ~loc ()) declaration.ptype_params)) in
+      (record_type ()) 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]
-        (if List.length fields = 1 then None else Some source) in
+    let replace expression = Exp.constraint_ ~loc
+        (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 ->
-          match configured declaration with
-          | Some options -> generate options declaration
-          | None -> []) declarations) in
+        let configurations = List.map configured declarations in
+        let generated =
+          if List.exists (function Some _ -> true | None -> false) configurations then
+            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