diff --git a/record.ml b/record.ml index 0595f6b..7d2ff01 100644 --- a/record.ml +++ b/record.ml @@ -69,3 +69,17 @@ 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) + +module Named = struct + type t = { item_colour : string; item_size : int } + [@@fieldglass generate ~field_prefix:swatch] +end + +module Typed = struct + type swatch = { item_colour : string; item_size : int } + [@@fieldglass generate ~field_prefix_from_type] +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) diff --git a/rewrite.ml b/rewrite.ml index 0a9155a..e18cf3a 100644 --- a/rewrite.ml +++ b/rewrite.ml @@ -9,11 +9,43 @@ 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 } + +let word expression = + match expression.pexp_desc with + | Pexp_ident { txt = Longident.Lident name; _ } + | Pexp_constant (Pconst_string (name, _)) -> name + | _ -> Location.raise_errorf ~loc:expression.pexp_loc + "fieldglass: expected an identifier or string" + +let flag name expression = + match expression.pexp_desc with + | Pexp_ident { txt = Longident.Lident value; _ } when value = name -> true + | Pexp_construct ({ txt = Longident.Lident "true"; _ }, None) -> true + | Pexp_construct ({ txt = Longident.Lident "false"; _ }, None) -> false + | _ -> Location.raise_errorf ~loc:expression.pexp_loc + "fieldglass: expected a boolean for %s" name + +let configure options (label, expression) = + match label with + | Labelled "field_prefix" -> { field_prefix = Named (word expression) } + | Labelled "field_prefix_from_type" -> + { field_prefix = if flag "field_prefix_from_type" expression then Type_name else Plain } + | _ -> Location.raise_errorf ~loc:expression.pexp_loc + "fieldglass: unrecognised configuration option" + let configured declaration = match List.filter is_marker declaration.ptype_attributes with - | [] -> false - | [(_, PStr [{ pstr_desc = Pstr_eval - ({ pexp_desc = Pexp_ident { txt = Longident.Lident "generate"; _ }; _ }, _); _ }])] -> true + | [] -> None + | [(_, PStr [{ pstr_desc = Pstr_eval (expression, []); _ }])] -> + let arguments = match expression.pexp_desc with + | Pexp_ident { txt = Longident.Lident "generate"; _ } -> [] + | 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) | _ -> Location.raise_errorf ~loc:declaration.ptype_loc "fieldglass: expected [@@fieldglass generate]" @@ -32,7 +64,7 @@ let field_names fields = let count = boundary shared in List.map (fun name -> String.sub name count (String.length name - count)) names -let generate declaration = +let generate options declaration = let loc = declaration.ptype_loc in let fields = match declaration.ptype_kind with | Ptype_record fields -> fields @@ -44,6 +76,10 @@ let generate declaration = (List.map (fun _ -> Typ.any ~loc ()) declaration.ptype_params)) in List.concat (List.map2 (fun field short_name -> let name = field.pld_name.txt in + let short_name = match options.field_prefix with + | Plain -> short_name + | Named prefix -> prefix ^ "_" ^ short_name + | 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] @@ -65,7 +101,9 @@ let structure mapper items = match item.pstr_desc with | Pstr_type (recursive, declarations) -> let generated = List.concat (List.map (fun declaration -> - if configured declaration then generate declaration else []) declarations) in + match configured declaration with + | Some options -> generate options declaration + | None -> []) declarations) in let declarations = List.map (fun declaration -> { declaration with ptype_attributes = List.filter (fun attribute -> not (is_marker attribute)) declaration.ptype_attributes }) declarations in