Parse labelled configuration and customise record prefixes

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)

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