Emit standalone lens pairs for nested record composition
This commit is contained in:
2 files changed
+16
-1
No files matched your search
@@ -38,3 +38,17 @@ let () =
|
|||||||
(try ignore (Colour.update_red ~f:(fun _ -> failwith "callback") original); assert false
|
(try ignore (Colour.update_red ~f:(fun _ -> failwith "callback") original); assert false
|
||||||
with Failure message -> assert (message = "callback"));
|
with Failure message -> assert (message = "callback"));
|
||||||
assert (Colour.red original = 3)
|
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" })
|
||||||
+2
-1
@@ -41,7 +41,8 @@ let generate declaration =
|
|||||||
[Nolabel, Exp.field ~loc source (ident ~loc name)]))) in
|
[Nolabel, Exp.field ~loc source (ident ~loc name)]))) in
|
||||||
List.map (fun (name, body) ->
|
List.map (fun (name, body) ->
|
||||||
Str.value ~loc Nonrecursive [Vb.mk ~loc (variable ~loc name) body])
|
Str.value ~loc Nonrecursive [Vb.mk ~loc (variable ~loc name) body])
|
||||||
[name, getter; "set_" ^ name, setter; "update_" ^ name, updater]) fields)
|
[name, getter; "set_" ^ name, setter; "update_" ^ name, updater;
|
||||||
|
"_" ^ name, Exp.tuple ~loc [getter; setter]]) fields)
|
||||||
|
|
||||||
let structure mapper items =
|
let structure mapper items =
|
||||||
List.concat (List.map (fun item ->
|
List.concat (List.map (fun item ->
|
||||||
|
|||||||
Reference in new issue
Block a user