diff --git a/record.ml b/record.ml index b8e5366..a88d379 100644 --- a/record.ml +++ b/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) diff --git a/rewrite.ml b/rewrite.ml index d1fa119..56b4a50 100644 --- a/rewrite.ml +++ b/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