Compare commits
10
Commits
master
..
c2d6f2aa05
| Author | SHA1 | Date | |
|---|---|---|---|
 milner
|
c2d6f2aa05 | ||
|
milner
|
40dc020f24 | ||
|
milner
|
4eda2052af | ||
|
milner
|
59e39e593c | ||
|
milner
|
a7237a6412 | ||
|
milner
|
d8c191be6d | ||
|
milner
|
28d28de6fa | ||
|
milner
|
d996eba971 | ||
|
milner
|
0f219fea14 | ||
|
milner
|
d30dc5d519 |
No files matched your search
@@ -20,10 +20,6 @@ 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
|
||||
@@ -1,113 +1,10 @@
|
||||
# fieldglass
|
||||
|
||||
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.
|
||||
Lenses for reading and updating immutable data in OCaml.
|
||||
|
||||
```ocaml
|
||||
type swatch = { colour : string; label : string }
|
||||
[@@fieldglass generate]
|
||||
Annotate a record with `[@@fieldglass generate]` to generate field accessors.
|
||||
The `[@@lens generate]` spelling is also accepted.
|
||||
|
||||
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
|
||||
```
|
||||
Build with `make`; run the checks with `make test`.
|
||||
|
||||
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.
|
||||
The `_hd` and `_tl` lenses raise `Invalid_argument` on empty lists.
|
||||
@@ -1,62 +0,0 @@
|
||||
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)
|
||||
@@ -1,49 +0,0 @@
|
||||
#!/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'
|
||||
@@ -38,119 +38,3 @@ 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)
|
||||
+20
-162
@@ -9,194 +9,52 @@ 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
|
||||
| [] -> 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
|
||||
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
|
||||
| [] -> false
|
||||
| [(_, PStr [{ pstr_desc = Pstr_eval
|
||||
({ pexp_desc = Pexp_ident { txt = Longident.Lident "generate"; _ }; _ }, _); _ }])] -> true
|
||||
| _ -> Location.raise_errorf ~loc:declaration.ptype_loc
|
||||
"fieldglass: expected [@@fieldglass generate]"
|
||||
|
||||
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 generate 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")
|
||||
(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
|
||||
if self_first then self (other body) else other (self body) in
|
||||
List.concat (List.map2 (fun field short_name ->
|
||||
(Typ.constr ~loc (ident ~loc declaration.ptype_name.txt)
|
||||
(List.map (fun _ -> Typ.any ~loc ()) declaration.ptype_params)) in
|
||||
List.concat (List.map (fun field ->
|
||||
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.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
|
||||
let updater = arguments options.self_first label "__fg_function"
|
||||
let replace expression = Exp.record ~loc [ident ~loc name, expression]
|
||||
(if List.length fields = 1 then None else Some source) in
|
||||
let setter = lambda ~loc Nolabel (variable ~loc "__fg_value")
|
||||
(lambda ~loc Nolabel source_pattern (replace (value ~loc "__fg_value"))) in
|
||||
let updater = lambda ~loc (Labelled "f") (variable ~loc "__fg_function")
|
||||
(lambda ~loc Nolabel source_pattern
|
||||
(replace (Exp.apply ~loc (value ~loc "__fg_function")
|
||||
[Nolabel, Exp.field ~loc source (ident ~loc name)])) in
|
||||
List.concat (List.map (fun (enabled, name, body) ->
|
||||
if enabled then begin
|
||||
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))
|
||||
[Nolabel, Exp.field ~loc source (ident ~loc name)]))) in
|
||||
List.map (fun (name, body) ->
|
||||
Str.value ~loc Nonrecursive [Vb.mk ~loc (variable ~loc name) body])
|
||||
[name, getter; "set_" ^ name, setter; "update_" ^ name, updater]) 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 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 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 generated = List.concat (List.map (fun declaration ->
|
||||
if configured declaration then generate declaration else []) 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
|
||||
{ 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; signature_item })
|
||||
(fun _ -> { Ast_mapper.default_mapper with structure })
|
||||
@@ -1,33 +0,0 @@
|
||||
#!/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"
|
||||
Reference in new issue
Block a user