Verify rewriter and runtime linkage through explicit interfaces

Makefile

@@ -20,6 +20,10 @@ test: all
 	./runtime.byte
 	$(OCAMLC) -ppx ./rewrite fieldglass.cma record.ml -o record.byte
 	./record.byte
+	$(OCAMLC) -ppx ./rewrite fieldglass.cma case.ml -o case.byte
+	./case.byte
+	OCAMLC=$(OCAMLC) sh error.sh
+	OCAMLC=$(OCAMLC) sh smoke.sh ./rewrite .
 
 clean:
 	rm -f *.cmi *.cmo *.cma *.byte rewrite

README.md

@@ -1,10 +1,113 @@
 # fieldglass
 
-Lenses for reading and updating immutable data in OCaml.
+Generates accessors and composable lenses from OCaml record
+declarations, allowing a caller to read or replace a nested field through
+ordinary functions while retaining the surrounding record structure.
 
-Annotate a record with `[@@fieldglass generate]` to generate field accessors.
+```ocaml
-The `[@@lens generate]` spelling is also accepted.
+type swatch = { colour : string; label : string }
+  [@@fieldglass generate]
 
-Build with `make`; run the checks with `make test`.
+let grey = { colour = "grey"; label = "sample" }
+let blue = set_colour "blue" grey
+let labelled = update_label ~f:String.uppercase_ascii grey
+let colour = Fieldglass.view _colour blue
+```
 
-The `_hd` and `_tl` lenses raise `Invalid_argument` on empty lists.
+For each field, the rewriter emits a getter, a setter prefixed with `set_`, an
+updater prefixed with `update_`, and a getter/setter pair whose name begins
+with `_`. A setter takes the replacement value followed by the source record,
+while an updater applies its labelled `~f` argument to the existing field
+value and constructs a replacement record containing the result.
+
+Generated updates retain the unfocussed fields and perform no assignment to
+the source record, including when the declaration contains mutable fields.
+Both `[@@fieldglass generate]` and `[@@lens generate]` select this expansion,
+which produces ordinary OCaml functions that can be used independently of
+the `Fieldglass` runtime's composition operations.
+
+## Build
+
+Run `make` to compile the runtime archive and PPX executable, or `make test`
+to also check lens operations, generated record accessors, configuration
+errors, and linkage against an explicit module interface.
+
+To compile a consumer, pass the rewriter through `-ppx` and link the runtime
+archive before the source file, as in the following invocation:
+
+```sh
+ocamlc -ppx ./rewrite fieldglass.cma example.ml -o example
+```
+
+The command `OPAMBUILDTEST=true opam pin add fieldglass .` builds and tests
+the package before installing the `fieldglass` rewriter and runtime library.
+Use the same OCaml compiler for the rewriter and its consumers, since the
+PPX exchanges compiler syntax trees and links against the compiler libraries.
+
+## Lenses
+
+`Fieldglass.lens ~view ~set` constructs a pair with representation
+`('s -> 'a) * ('b -> 's -> 't)`, where the getter extracts a value from the
+source and the setter combines a replacement with that source to produce
+the result. The separate type parameters permit a lens to change the type
+of its focussed value when the enclosing structure admits that change.
+
+`view` applies the getter, `set` applies the setter, and `over ~f` passes the
+getter's result through `f` before supplying it to the setter alongside the
+original source. With `compose outer inner`, reading follows the outer getter
+and then the inner getter; replacement updates the inner structure before
+passing it back through the outer setter, preserving the surrounding data
+according to the supplied setters.
+
+`Fieldglass.Infix` exposes these operations as `^.`, `^~`, and `^%`, with
+`^>` composing an outer lens with an inner lens and `^<` accepting the same
+operands in reverse order. The runtime also supplies tuple projections and
+the identity lens `_id`, together with `_hd` and `_tl` for focussing on a
+list's head or tail; either list lens raises `Invalid_argument` when asked
+to read or update an empty list.
+
+## Configuration
+
+Supply labelled options after `generate` to control the generated names,
+argument order, and selection of operations, using identifiers or strings
+for prefixes and argument names. Boolean options accept a bare label as an
+enabled flag, or an explicit `true` or `false` value when the configuration
+needs to specify the setting directly.
+
+| Option | Behaviour |
+| --- | --- |
+| `~field_prefix:name` | Add a prefix to each field name. |
+| `~field_prefix_from_type` | Use the record type name as the prefix. |
+| `~get_prefix:name` | Prefix getter names. |
+| `~set_prefix:name` | Replace the `set` prefix. |
+| `~update_prefix:name` | Replace the `update` prefix. |
+| `~self_arg_first` | Put the record first in setters and updaters. |
+| `~func_named_arg:name` | Rename the updater's `f` argument. |
+| `~func_no_named_arg` | Make the updater's function argument positional. |
+| `~no_get` | Omit getters. |
+| `~no_set` | Omit setters. |
+| `~no_update` | Omit updaters. |
+| `~no_lens` | Omit lens pairs. |
+| `~just_lens` | Generate lens pairs without named accessors. |
+
+Before applying naming options, the rewriter removes the longest shared
+field prefix ending at an underscore boundary, so fields such as
+`paint_colour` and `paint_label` produce the base names `colour` and `label`.
+A record containing only one field keeps that field's complete name, while
+generated lens pairs retain replacement-first setters even when
+`~self_arg_first` changes the argument order of the named accessors.
+
+An annotation attached to a mutually recursive record declaration applies
+to the entire declaration group, whose options the rewriter processes from
+left to right with later settings taking precedence. When records share
+field labels, `~field_prefix_from_type` gives their accessors distinct names;
+the rewriter rejects duplicate generated bindings and repeated options
+within a single annotation with a compilation error.
+
+Place generation annotations on record declarations in implementations and
+declare the exported accessor types explicitly in module signatures, since
+the rewriter emits value bindings and rejects generation annotations in
+signatures. For private records or records containing universally quantified
+fields, select `~no_set ~no_update ~no_lens` to generate getters without
+requesting replacement operations that the rewriter does not generate for
+those declarations.

case.ml

@@ -0,0 +1,62 @@
+module Parameter = struct
+  type 'a t = { value : 'a; label : string } [@@fieldglass generate]
+end
+
+module Private = struct
+  type t = private { value : int }
+    [@@fieldglass generate ~no_set ~no_update ~no_lens]
+  let read : t -> int = value
+end
+
+module Universal = struct
+  type t = { apply : 'a. 'a -> 'a }
+    [@@fieldglass generate ~no_set ~no_update ~no_lens]
+end
+
+module Flags = struct
+  type t = { count : int }
+    [@@fieldglass generate ~no_get:false ~no_set:false ~no_update:false
+       ~no_lens:false ~just_lens:false ~self_arg_first:false
+       ~field_prefix_from_type:false ~func_no_named_arg:false]
+end
+
+module Group = struct
+  type left = { count : int } [@@fieldglass generate ~get_prefix:read]
+  and right = { size : int } [@@fieldglass generate ~field_prefix_from_type]
+end
+
+module Names = struct
+  type t = { __fg_source : int; __fg_value : string; __fg_function : bool }
+    [@@fieldglass generate ~field_prefix:local]
+end
+
+module Alias = struct
+  type original = { number : int; label : string }
+  type t = original = { number : int; label : string } [@@fieldglass generate]
+end
+
+module Unmarked = struct
+  type t = { number : int }
+  let number _ = 99
+end
+
+let () =
+  let original = Parameter.{ value = 3; label = "grey" } in
+  let changed = Parameter.set_value "three" original in
+  assert (changed = Parameter.{ value = "three"; label = "grey" });
+  assert (Parameter.update_value ~f:string_of_int original = Parameter.{ value = "3"; label = "grey" });
+  assert (Fieldglass.set Parameter._value "three" original = changed);
+  let identity = Universal.{ apply = fun value -> value } in
+  assert (Universal.apply identity 3 = 3);
+  assert (Universal.apply identity "grey" = "grey");
+  let count = Flags.{ count = 3 } in
+  assert (Flags.count (Flags.set_count 4 count) = 4);
+  assert (Flags.count (Flags.update_count ~f:succ count) = 4);
+  assert (Fieldglass.view Flags._count count = 3);
+  assert (Group.read_left_count Group.{ count = 3 } = 3);
+  assert (Group.read_right_size Group.{ size = 4 } = 4);
+  let names = Names.{ __fg_source = 3; __fg_value = "grey"; __fg_function = true } in
+  assert (Names.local_source names = 3);
+  assert (Names.local_value (Names.set_local_value "blue" names) = "blue");
+  assert (Alias.number (Alias.set_number 4 Alias.{ number = 3; label = "grey" }) = 4);
+  assert (Unmarked.number Unmarked.{ number = 3 } = 99)

error.sh

@@ -0,0 +1,49 @@
+#!/bin/sh
+set -eu
+directory=$(mktemp -d)
+trap 'rm -rf "$directory"' EXIT HUP INT TERM
+
+reject() {
+  printf '%s\n' "$1" > "$directory/rejected.ml"
+  if "${OCAMLC:-ocamlc}" -ppx ./rewrite -c "$directory/rejected.ml" 2> "$directory/error"; then
+    echo "Unexpected compilation success: $1" >&2
+    exit 1
+  fi
+  if ! grep -q "$2" "$directory/error"; then
+    cat "$directory/error" >&2
+    exit 1
+  fi
+}
+
+reject 'type t = { colour : string } [@@fieldglass generate ~no_get]
+let _ = colour' 'Unbound value colour'
+reject 'type t = A [@@fieldglass generate]' 'fieldglass: expected a record'
+reject 'type t = { colour : string } [@@fieldglass invalid]' 'fieldglass: expected generate'
+reject 'type t = { colour : string } [@@fieldglass generate ~unknown]' 'fieldglass: unrecognised'
+reject 'type t = { colour : string } [@@fieldglass generate ~no_get:3]' 'fieldglass: expected a boolean'
+reject 'type t = { colour : string } [@@fieldglass generate ~field_prefix:3]' 'fieldglass: expected an identifier'
+reject 'type t = { colour : string } [@@fieldglass generate ~field_prefix:"a b"]' 'fieldglass: invalid generated identifier'
+reject 'type t = { colour : string } [@@fieldglass generate ~func_named_arg:"type"]' 'fieldglass: invalid generated identifier'
+reject 'type t = { colour : string } [@@fieldglass generate ~no_get ~no_get]' 'fieldglass: duplicate option'
+reject 'type t = { colour : string } [@@fieldglass generate 3]' 'fieldglass: expected a labelled option'
+reject 'type t = { colour : string } [@@fieldglass generate] [@@lens generate]' 'fieldglass: expected'
+reject 'type t = { x : int; set_x : int } [@@fieldglass generate]' 'fieldglass: duplicate generated binding'
+reject 'type a = { value : int } and b = { value : string } [@@fieldglass generate]' 'fieldglass: duplicate generated binding'
+reject 'type t = private { colour : string } [@@fieldglass generate]' 'fieldglass: private records'
+reject "type t = { apply : 'a. 'a -> 'a } [@@fieldglass generate]" 'fieldglass: polymorphic fields'
+reject 'module type S = sig type t = { colour : string } [@@fieldglass generate] end' 'fieldglass: generate accessors in an implementation'
+reject 'type t = { item_type : int; item_value : int } [@@fieldglass generate]' 'fieldglass: invalid generated identifier'
+reject 'type t = { item_ : int; item_value : int } [@@fieldglass generate]' 'fieldglass: invalid generated identifier'
+reject 'type t = { value : int } [@@fieldglass generate ?no_get:None]' 'fieldglass: expected a labelled option'
+reject 'type t = { value : int } [@@fieldglass generate ~just_lens]
+let _ = set_value' 'Unbound value set_value'
+reject 'type t = { value : int } [@@fieldglass generate ~just_lens]
+let _ = update_value' 'Unbound value update_value'
+reject 'type t = { colour : string } [@@fieldglass generate ~no_set]
+let _ = set_colour' 'Unbound value set_colour'
+reject 'type t = { colour : string } [@@fieldglass generate ~no_update]
+let _ = update_colour' 'Unbound value update_colour'
+reject 'type t = { colour : string } [@@fieldglass generate ~no_lens]
+let _ = _colour' 'Unbound value _colour'
+reject 'type t = { colour : string } [@@fieldglass generate ~just_lens]
+let _ = colour' 'Unbound value colour'

record.ml

@@ -38,3 +38,119 @@ let () =
   (try ignore (Colour.update_red ~f:(fun _ -> failwith "callback") original); assert false
    with Failure message -> assert (message = "callback"));
   assert (Colour.red original = 3)
+
+module Swatch = struct
+  type t = { colour : Colour.t; label : string } [@@fieldglass generate]
+end
+
+let () =
+  let open Fieldglass in
+  let original = Swatch.{ colour = Colour.{ red = 3; green = 4; blue = 5 }; label = "grey" } in
+  let focus = compose Swatch._colour Colour._red in
+  assert (view focus original = 3);
+  let changed = set focus 8 original in
+  assert (view focus changed = 8 && Swatch.label changed = "grey");
+  assert (set focus (view focus original) original = original);
+  assert (set Box._contents "grey" Box.{ contents = 9 } = Box.{ contents = "grey" })
+
+module Prefixed = struct
+  type t = { paint_colour_red : int; paint_colour_green : int } [@@fieldglass generate]
+end
+
+module Unprefixed = struct
+  type t = { yes : bool; yellow : bool } [@@fieldglass generate]
+end
+
+module Single = struct
+  type t = { paint_red : int } [@@fieldglass generate]
+end
+
+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)
+
+module Verbs = struct
+  type t = { colour : string }
+    [@@fieldglass generate ~get_prefix:read ~set_prefix:replace ~update_prefix:"revise"]
+end
+
+let () =
+  let original = Verbs.{ colour = "grey" } in
+  assert (Verbs.read_colour original = "grey");
+  assert (Verbs.read_colour (Verbs.replace_colour "blue" original) = "blue");
+  assert (Verbs.read_colour (Verbs.revise_colour ~f:(fun s -> s ^ "s") original) = "greys");
+  assert (Fieldglass.view Verbs._colour original = "grey")
+
+module Ordered = struct
+  type t = { count : int }
+    [@@fieldglass generate ~self_arg_first ~func_named_arg:change]
+end
+
+module Positional = struct
+  type t = { count : int }
+    [@@fieldglass generate ~self_arg_first ~func_no_named_arg]
+end
+
+module Last = struct
+  type t = { count : int } [@@fieldglass generate ~func_no_named_arg]
+end
+
+let () =
+  assert (Ordered.set_count Ordered.{ count = 1 } 2 = Ordered.{ count = 2 });
+  assert (Ordered.update_count Ordered.{ count = 1 } ~change:succ = Ordered.{ count = 2 });
+  assert (Fieldglass.set Ordered._count 2 Ordered.{ count = 1 } = Ordered.{ count = 2 });
+  assert (Positional.update_count Positional.{ count = 1 } succ = Positional.{ count = 2 });
+  assert (Last.update_count succ Last.{ count = 1 } = Last.{ count = 2 })
+
+module Pairs = struct
+  type t = { colour : string } [@@fieldglass generate ~just_lens]
+end
+
+module Silent = struct
+  type t = { colour : string } [@@fieldglass generate ~just_lens ~no_lens]
+end
+
+module Functions = struct
+  type t = { colour : string } [@@fieldglass generate ~no_lens ~no_get:false]
+end
+
+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

@@ -9,52 +9,194 @@ let lambda ~loc label pattern body = Exp.fun_ ~loc label None pattern body
 
 let is_marker (name, _) = name.txt = "fieldglass" || name.txt = "lens"
 
+let check_identifier ~loc name =
+  let input = Lexing.from_string name in
+  let valid = try
+      match Lexer.token input with
+      | Parser.LIDENT parsed when parsed = name -> Lexer.token input = Parser.EOF
+      | _ -> false
+    with Lexer.Error _ -> false in
+  if not valid then Location.raise_errorf ~loc
+      "fieldglass: invalid generated identifier %S" name
+
+type prefix = Plain | Named of string | Type_name
+type options = {
+  field_prefix : prefix;
+  get_prefix : string option;
+  set_prefix : string;
+  update_prefix : string;
+  self_first : bool;
+  function_label : string option;
+  getters : bool;
+  setters : bool;
+  updaters : bool;
+  lenses : bool;
+}
+let defaults = { field_prefix = Plain; get_prefix = None;
+                 set_prefix = "set"; update_prefix = "update";
+                 self_first = false; function_label = Some "f";
+                 getters = true; setters = true; updaters = true; lenses = true }
+
+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" -> { options with field_prefix = Named (word expression) }
+  | Labelled "field_prefix_from_type" ->
+      { options with field_prefix = if flag "field_prefix_from_type" expression then Type_name else Plain }
+  | Labelled "get_prefix" -> { options with get_prefix = Some (word expression) }
+  | Labelled "set_prefix" -> { options with set_prefix = word expression }
+  | Labelled "update_prefix" -> { options with update_prefix = word expression }
+  | Labelled "self_arg_first" -> { options with self_first = flag "self_arg_first" expression }
+  | Labelled "func_named_arg" ->
+      let name = word expression in
+      check_identifier ~loc:expression.pexp_loc name;
+      { options with function_label = Some name }
+  | Labelled "func_no_named_arg" ->
+      { options with function_label = if flag "func_no_named_arg" expression then None else Some "f" }
+  | Labelled "no_get" -> { options with getters = not (flag "no_get" expression) }
+  | Labelled "no_set" -> { options with setters = not (flag "no_set" expression) }
+  | Labelled "no_update" -> { options with updaters = not (flag "no_update" expression) }
+  | Labelled "no_lens" -> { options with lenses = not (flag "no_lens" expression) }
+  | Labelled "just_lens" ->
+      let functions = not (flag "just_lens" expression) in
+      { options with getters = functions; setters = functions; updaters = functions }
+  | _ -> Location.raise_errorf ~loc:expression.pexp_loc
+      "fieldglass: unrecognised configuration option"
+
 let configured declaration =
   match List.filter is_marker declaration.ptype_attributes with
-  | [] -> false
+  | [] -> None
-  | [(_, PStr [{ pstr_desc = Pstr_eval
+  | [(_, PStr [{ pstr_desc = Pstr_eval (expression, []); _ }])] ->
-      ({ pexp_desc = Pexp_ident { txt = Longident.Lident "generate"; _ }; _ }, _); _ }])] -> true
+      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
+      let seen = Hashtbl.create 8 in
+      List.iter (fun (label, argument) ->
+        match label with
+        | Labelled name ->
+            if Hashtbl.mem seen name then Location.raise_errorf ~loc:argument.pexp_loc
+                "fieldglass: duplicate option %s" name;
+            Hashtbl.add seen name ()
+        | _ -> Location.raise_errorf ~loc:argument.pexp_loc
+            "fieldglass: expected a labelled option") arguments;
+      Some arguments
   | _ -> Location.raise_errorf ~loc:declaration.ptype_loc
       "fieldglass: expected [@@fieldglass generate]"
 
-let generate declaration =
+let field_names fields =
+  let names = List.map (fun field -> field.pld_name.txt) fields in
+  match names with
+  | [] | [_] -> names
+  | first :: rest ->
+      let shared = List.fold_left (fun limit name ->
+        let limit = min limit (String.length name) in
+        let rec compare i =
+          if i < limit && first.[i] = name.[i] then compare (i + 1) else i in
+        compare 0) (String.length first) rest in
+      let rec boundary n =
+        if n = 0 || first.[n - 1] = '_' then n else boundary (n - 1) in
+      let count = boundary shared in
+      List.map (fun name -> String.sub name count (String.length name - count)) names
+
+let generate options declaration =
   let loc = declaration.ptype_loc in
   let fields = match declaration.ptype_kind with
     | Ptype_record fields -> fields
     | _ -> Location.raise_errorf ~loc "fieldglass: expected a record type"
   in
+  let writes = options.setters || options.updaters || options.lenses in
+  if declaration.ptype_private = Private && writes then
+    Location.raise_errorf ~loc "fieldglass: private records only support getters";
+  List.iter (fun field -> match field.pld_type.ptyp_desc with
+    | Ptyp_poly (_ :: _, _) when writes -> Location.raise_errorf ~loc:field.pld_loc
+        "fieldglass: polymorphic fields only support getters"
+    | _ -> ()) fields;
   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 =
-  List.concat (List.map (fun field ->
+    let self = lambda ~loc Nolabel source_pattern in
+    let other = lambda ~loc label (variable ~loc name) in
+    if self_first then self (other body) else other (self body) 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]
+    let replace expression = Exp.constraint_ ~loc
-        (if List.length fields = 1 then None else Some source) in
+        (Exp.record ~loc [ident ~loc name, expression]
-    let setter = lambda ~loc Nolabel (variable ~loc "__fg_value")
+           (if List.length fields = 1 then None else Some source)) (record_type ()) in
-        (lambda ~loc Nolabel source_pattern (replace (value ~loc "__fg_value"))) in
+    let setter self_first = arguments self_first Nolabel "__fg_value"
-    let updater = lambda ~loc (Labelled "f") (variable ~loc "__fg_function")
+        (replace (value ~loc "__fg_value")) in
-        (lambda ~loc Nolabel source_pattern
+    let label = match options.function_label with None -> Nolabel | Some name -> Labelled name in
+    let updater = arguments options.self_first label "__fg_function"
            (replace (Exp.apply ~loc (value ~loc "__fg_function")
-              [Nolabel, Exp.field ~loc source (ident ~loc name)]))) in
+              [Nolabel, Exp.field ~loc source (ident ~loc name)])) in
-    List.map (fun (name, body) ->
+    List.concat (List.map (fun (enabled, name, body) ->
-      Str.value ~loc Nonrecursive [Vb.mk ~loc (variable ~loc name) body])
+      if enabled then begin
-      [name, getter; "set_" ^ name, setter; "update_" ^ name, updater]) fields)
+        check_identifier ~loc name;
+        [Str.value ~loc Nonrecursive [Vb.mk ~loc (variable ~loc name) body]]
+      end else [])
+      [options.getters, (match options.get_prefix with None -> short_name | Some prefix -> prefix ^ "_" ^ short_name), getter;
+       options.setters, options.set_prefix ^ "_" ^ short_name, setter options.self_first;
+       options.updaters, options.update_prefix ^ "_" ^ short_name, updater;
+       options.lenses, "_" ^ short_name, Exp.tuple ~loc [getter; setter false]])) fields (field_names fields))
 
 let structure mapper items =
   List.concat (List.map (fun item ->
     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
-          if configured declaration then generate declaration else []) 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 names = Hashtbl.create 16 in
+        List.iter (fun item -> match item.pstr_desc with
+          | Pstr_value (_, [{ pvb_pat = { ppat_desc = Ppat_var name; _ }; _ }]) ->
+              if Hashtbl.mem names name.txt then Location.raise_errorf ~loc:name.loc
+                  "fieldglass: duplicate generated binding %s; customise the prefixes" name.txt;
+              Hashtbl.add names name.txt ()
+          | _ -> ()) generated;
         let declarations = List.map (fun declaration ->
           { declaration with ptype_attributes =
               List.filter (fun attribute -> not (is_marker attribute)) declaration.ptype_attributes }) declarations in
         { item with pstr_desc = Pstr_type (recursive, declarations) } :: generated
     | _ -> [item]) items)
 
+let signature_item mapper item =
+  (match item.psig_desc with
+   | Psig_type (_, declarations) ->
+       List.iter (fun declaration ->
+         if List.exists is_marker declaration.ptype_attributes then
+           Location.raise_errorf ~loc:declaration.ptype_loc
+             "fieldglass: generate accessors in an implementation, not a signature") declarations
+   | _ -> ());
+  Ast_mapper.default_mapper.signature_item mapper item
+
 let () = Ast_mapper.register "fieldglass"
-    (fun _ -> { Ast_mapper.default_mapper with structure })
+    (fun _ -> { Ast_mapper.default_mapper with structure; signature_item })

smoke.sh

@@ -0,0 +1,33 @@
+#!/bin/sh
+set -eu
+compiler=${OCAMLC:-ocamlc}
+rewriter=$(cd "$(dirname "$1")" && pwd)/$(basename "$1")
+library=$(cd "$2" && pwd)
+directory=$(mktemp -d)
+trap 'rm -rf "$directory"' EXIT HUP INT TERM
+
+cat > "$directory/unit.mli" <<'ML'
+type t = { colour : string; label : string }
+val colour : t -> string
+val set_colour : string -> t -> t
+val _colour : (t -> string) * (string -> t -> t)
+ML
+
+cat > "$directory/unit.ml" <<'ML'
+type t = { colour : string; label : string } [@@fieldglass generate]
+ML
+
+cat > "$directory/client.ml" <<'ML'
+let () =
+  let original = Unit.{ colour = "grey"; label = "sample" } in
+  let changed = Fieldglass.over Unit._colour ~f:String.uppercase_ascii original in
+  assert (Unit.colour changed = "GREY");
+  assert (changed.Unit.label = original.Unit.label);
+  assert (Unit.colour original = "grey")
+ML
+
+"$compiler" -c "$directory/unit.mli"
+"$compiler" -I "$directory" -ppx "$rewriter" -c "$directory/unit.ml"
+"$compiler" -I "$library" -I "$directory" "$library/fieldglass.cma" \
+  "$directory/unit.cmo" "$directory/client.ml" -o "$directory/client.byte"
+"$directory/client.byte"