diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..591ec79 --- /dev/null +++ b/.gitignore @@ -0,0 +1,30 @@ +*.annot +*.cmo +*.cma +*.cmi +*.a +*.o +*.cmx +*.cmxs +*.cmxa + +# ocamlbuild working directory +_build/ + +# ocamlbuild targets +*.byte +*.native + +# oasis generated files +setup.data +setup.log + +# Merlin configuring file for Vim and Emacs +.merlin + +# Dune generated files +*.install + +# Local OPAM switch +_opam/ + diff --git a/.ocamlformat b/.ocamlformat new file mode 100644 index 0000000..37525ae --- /dev/null +++ b/.ocamlformat @@ -0,0 +1 @@ +profile = default diff --git a/CHANGES b/CHANGES new file mode 100644 index 0000000..bd4547b --- /dev/null +++ b/CHANGES @@ -0,0 +1,3 @@ +1.0.0 +======== +- #1: initial implementation diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..d3ace24 --- /dev/null +++ b/LICENSE @@ -0,0 +1,7 @@ +Copyright 2023 Skolem Technologies US Corp + +Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the “Software”), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED “AS IS”, WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/README.md b/README.md new file mode 100644 index 0000000..76854c5 --- /dev/null +++ b/README.md @@ -0,0 +1,44 @@ +# diff +An OCaml library for generating diffs of product types. + +## Example +```ocaml +type t = { foo : int; bar : string; } +[@@deriving diff] + +let spec = Diff.many [ + Diff.leaf ~field:Foo ~equal:Int.equal; + Diff.leaf ~field:Bar ~equal:String.equal; +] + +let () = + let t0 = { foo = 1; bar = "Skolem" } in + let t1 = { foo = 1; bar = "OCaml" } in + let diff = Diff.compute t0 t1 spec in + let t0' = Diff.apply_all t0 diff in + assert (t0' = t1) +``` + +## Usage + +The main use case of this library is to version records without having to keep a copy of each version around. + +The library includes a ppx for generating field accessors from records. To use the ppx with dune, add it to the `preprocessing` field of your stanza: +```dune +(library + (name mylib) + ... + (preprocessing (pps diff.ppx))) +``` + +In order to actually compute diffs, you need to write a spec for how your record should be traversed. There are functions provided to help you do so: + +- `leaf ~field ~equal` represents a "terminal" node in the spec tree, i.e. the diffing algorithm should simply compare the field values and add it to the diff list if they are different. +- `child ~field ~spec` represents an "intermediate" node in the spec tree, i.e. the diffing algorithm should recursively compute the diff of a "child" record. +- `opt_child ~field ~spec` reprents an *optional* intermediate node in the spec tree, i.e. a child record that is optional in the parent. +- `many specs`: flattens many specs into a single one. + +For more usage examples, check out `example/example.ml` and `tests/*_test.ml`. + +## License +This project is licensed under the MIT License. diff --git a/diff.opam b/diff.opam new file mode 100644 index 0000000..6af2ec4 --- /dev/null +++ b/diff.opam @@ -0,0 +1,32 @@ +# This file is generated by dune, edit dune-project instead +opam-version: "2.0" +version: "1.0.0" +synopsis: "A library for generating diffs from product types" +maintainer: ["Zach Baylin "] +authors: ["Zach Baylin "] +license: "MIT" +homepage: "https://github.com/skolemlabs/diff" +bug-reports: "https://github.com/skolemlabs/diff/issues" +depends: [ + "dune" {>= "3.10"} + "ppxlib" {>= "0.25.0"} + "ocamlformat" {with-dev-setup} + "ppx_deriving" {with-test} + "tezt" {with-test & >= "3.1.1" & < "4.0.0"} + "odoc" {with-doc} +] +build: [ + ["dune" "subst"] {dev} + [ + "dune" + "build" + "-p" + name + "-j" + jobs + "@install" + "@runtest" {with-test} + "@doc" {with-doc} + ] +] +dev-repo: "git+https://github.com/skolemlabs/diff.git" diff --git a/dune-project b/dune-project new file mode 100644 index 0000000..af174ab --- /dev/null +++ b/dune-project @@ -0,0 +1,21 @@ +(lang dune 3.10) + +(name diff) + + +(generate_opam_files true) + +(version 1.0.0) +(source (github skolemlabs/diff)) +(license MIT) +(authors "Zach Baylin ") +(maintainers "Zach Baylin ") + +(package + (name diff) + (synopsis "A library for generating diffs from product types") + (depends + (ppxlib (>= 0.25.0)) + (ocamlformat :with-dev-setup) + (ppx_deriving :with-test) + (tezt (and :with-test (and (>= 3.1.1) (< 4.0.0)))))) diff --git a/example/dune b/example/dune new file mode 100644 index 0000000..aac5469 --- /dev/null +++ b/example/dune @@ -0,0 +1,4 @@ +(executable + (name example) + (preprocess + (pps ppx_diff))) diff --git a/example/example.ml b/example/example.ml new file mode 100644 index 0000000..8738617 --- /dev/null +++ b/example/example.ml @@ -0,0 +1,61 @@ +type foo = { x : int; y : string } [@@deriving diff] +type bar = { z : float; foo : foo } [@@deriving diff] +type recursive = { v : int; r : recursive option } [@@deriving diff] + +let bar () = + let bar = { foo = { x = 42; y = "Skolem" }; z = 1. } in + let f = Diff.Field.Infix.(Bar_foo --| Foo_x) in + let x' = 10 in + let () = Format.printf "Setting %a: %d\n%!" Diff.Field.pp f x' in + let bar' = Diff.Field.set bar f x' in + let x = Diff.Field.get bar' f in + Format.printf "Getting %a: %d\n%!" Diff.Field.pp f x + +let recursive () = + let recursive = { v = 1; r = Some { v = 2; r = None } } in + let f = Diff.Field.Infix.(Recursive_r --| ?*Recursive_r --| ?+Recursive_v) in + let v' = Some 3 in + let () = + Format.printf "Setting %a: %a\n%!" Diff.Field.pp f + (Format.pp_print_option Format.pp_print_int) + v' + in + let recursive' = Diff.Field.set recursive f v' in + let v = Diff.Field.get recursive' f in + Format.printf "Getting %a: %a\n%!" Diff.Field.pp f + (Format.pp_print_option Format.pp_print_int) + v + +let foo_spec = + Diff.( + many + [ + leaf ~field:Foo_x ~equal:Int.equal; + leaf ~field:Foo_y ~equal:String.equal; + ]) + +let bar_spec = + Diff.( + many + [ + leaf ~field:Bar_z ~equal:Float.equal; + child ~field:Bar_foo ~spec:foo_spec; + ]) + +let bar_diff () = + let bar0, bar1 = + ( { z = 2.; foo = { x = 0xdeadbeef; y = "Skolem" } }, + { z = 5.; foo = { x = 0x1337; y = "Skolem" } } ) + in + let diff = Diff.compute bar0 bar1 bar_spec in + Format.printf "Computed diff:\n"; + List.iter + (fun (Diff.Diff { field; _ }) -> Format.printf "\t%a\n" Diff.Field.pp field) + diff; + let bar0' = List.fold_left Diff.apply bar0 diff in + Format.printf "bar0' = bar1? %b\n%!" (bar0' = bar1) + +let () = + bar (); + recursive (); + bar_diff () diff --git a/src/main/diff.ml b/src/main/diff.ml new file mode 100644 index 0000000..b3f241d --- /dev/null +++ b/src/main/diff.ml @@ -0,0 +1,201 @@ +module Option_ext = struct + let value_lazy ~f o = match o with Some v -> v | None -> f () + + module Infix = struct + let ( >|= ) v f = Option.map f v + let ( >>= ) v f = Option.bind v f + end +end + +module Utils = struct + let pp_const : 'a. string -> Format.formatter -> 'a -> unit = + fun str fmt _ -> Format.pp_print_string fmt str +end + +module Field = struct + type (_, _) t = .. + + type (_, _) t += + | Cons : ('a, 'b) t * ('b, 'c) t -> ('a, 'c) t + | Opt_map : ('a, 'b) t -> ('a option, 'b option) t + | Opt_bind : ('a, 'b option) t -> ('a option, 'b option) t + + type abstr = Field : (_, _) t -> abstr [@@unboxed] + type getter = { f : 'a 'b. 'a -> ('a, 'b) t -> 'b option } [@@unboxed] + type setter = { f : 'a 'b. 'a -> ('a, 'b) t -> 'b -> 'a option } [@@unboxed] + + type error = + | Unknown_field : (_, _) t -> error + | Getter_invalid : (_, _) t -> error + | Setter_invalid : (_, _) t -> error + + exception Diff_field of error + + let getter_setter_map = Hashtbl.create 64 + let name_map = Hashtbl.create 64 + + let name : type a b. (a, b) t -> string option = + fun f -> Hashtbl.find_opt name_map (Field f) + + let cons : type a b c. (a, b) t -> (b, c) t -> (a, c) t = + fun l r -> Cons (l, r) + + let opt_map : type a b. (a, b) t -> (a option, b option) t = + fun f -> Opt_map f + + let opt_bind : type a b. (a, b option) t -> (a option, b option) t = + fun f -> Opt_bind f + + let register : type a b. ?name:string -> (a, b) t -> getter -> setter -> unit + = + fun ?name field getter setter -> + Hashtbl.replace getter_setter_map (Field field) (getter, setter); + Option.iter (Hashtbl.replace name_map (Field field)) name + + let rec pp : type a b. Format.formatter -> (a, b) t -> unit = + fun fmt t -> + match t with + | Cons (l, r) -> + pp fmt l; + Format.pp_print_string fmt " -> "; + pp fmt r + | Opt_map f -> + Format.pp_print_char fmt '?'; + pp fmt f + | Opt_bind f -> pp fmt f + | field -> + let name_opt = Hashtbl.find_opt name_map (Field field) in + Format.pp_print_option + ~none:(Utils.pp_const "(unknown)") + Format.pp_print_string fmt name_opt + + let pp_error fmt = function + | Unknown_field _ -> Format.pp_print_string fmt "unknown field" + | Getter_invalid f -> Format.fprintf fmt "getter invalid for field %a" pp f + | Setter_invalid f -> Format.fprintf fmt "setter invalid for field %a" pp f + + let rec get : type a b. a -> (a, b) t -> b = + fun v field -> + let open Option_ext.Infix in + match field with + | Cons (l, r) -> + let lv = get v l in + get lv r + | Opt_map f -> v >|= fun v -> get v f + | Opt_bind f -> v >>= fun v -> get v f + | _ -> + let g, _ = + Hashtbl.find_opt getter_setter_map (Field field) + |> Option_ext.value_lazy ~f:(fun () -> + raise (Diff_field (Unknown_field field))) + in + g.f v field + |> Option_ext.value_lazy ~f:(fun () -> + raise (Diff_field (Getter_invalid field))) + + let get_opt : type a b. a -> (a, b) t -> b option = + fun v field -> try Some (get v field) with Diff_field _ -> None + + let get_res : type a b. a -> (a, b) t -> (b, [> `Diff_field of error ]) result + = + fun v field -> + try Ok (get v field) with Diff_field e -> Error (`Diff_field e) + + let rec set : type a b. a -> (a, b) t -> b -> a = + fun v field x -> + let open Option_ext.Infix in + match field with + | Cons (l, r) -> + let lv = get v l in + let lv = set lv r x in + set v l lv + | Opt_map f -> + v >>= fun v -> + x >|= fun x -> set v f x + | Opt_bind f -> v >|= fun v -> set v f x + | _ -> + let _, s = + Hashtbl.find_opt getter_setter_map (Field field) + |> Option_ext.value_lazy ~f:(fun () -> + raise (Diff_field (Unknown_field field))) + in + s.f v field x + |> Option_ext.value_lazy ~f:(fun () -> + raise (Diff_field (Setter_invalid field))) + + let set_opt : type a b. a -> (a, b) t -> b -> a option = + fun v field x -> try Some (set v field x) with Diff_field _ -> None + + let set_res : + type a b. a -> (a, b) t -> b -> (a, [> `Diff_field of error ]) result = + fun v field x -> + try Ok (set v field x) with Diff_field e -> Error (`Diff_field e) + + module Infix = struct + let ( --| ) = cons + let ( ?+ ) = opt_map + let ( ?* ) = opt_bind + end +end + +type _ spec = + | Leaf : { field : ('a, 'b) Field.t; equal : 'b -> 'b -> bool } -> 'a spec + | Child : { field : ('a, 'b) Field.t; spec : 'b spec } -> 'a spec + | Opt_child : { field : ('a, 'b option) Field.t; spec : 'b spec } -> 'a spec + | Many : 'a spec list -> 'a spec + +let leaf : type a b. field:(a, b) Field.t -> equal:(b -> b -> bool) -> a spec = + fun ~field ~equal -> Leaf { field; equal } + +let child : type a b. field:(a, b) Field.t -> spec:b spec -> a spec = + fun ~field ~spec -> Child { field; spec } + +let opt_child : type a b. field:(a, b option) Field.t -> spec:b spec -> a spec = + fun ~field ~spec -> Opt_child { field; spec } + +let many : type a. a spec list -> a spec = fun v -> Many v + +type _ t = Diff : { field : ('a, 'b) Field.t; new_ : 'b } -> 'a t + +let compute : 'a. 'a -> 'a -> 'a spec -> 'a t list = + let rec helper : + type b c. b -> b -> b spec -> (b t -> c t) -> c t list -> c t list = + fun v0 v1 spec f acc -> + match spec with + | Leaf { field; equal } -> + let f0 = Field.get v0 field in + let f1 = Field.get v1 field in + if equal f0 f1 then acc else f (Diff { field; new_ = f1 }) :: acc + | Child { field; spec } -> + let c0 = Field.get v0 field in + let c1 = Field.get v1 field in + let f (Diff { field = field'; new_ }) = + f (Diff { field = Field.cons field field'; new_ }) + in + (helper [@tailcall]) c0 c1 spec f acc + | Opt_child { field; spec } -> ( + let o0 = Field.get v0 field in + let o1 = Field.get v1 field in + match (o0, o1, field) with + | None, None, _ -> acc + | Some _, None, _ | None, Some _, _ -> + f (Diff { field; new_ = o1 }) :: acc + | Some c0, Some c1, _ -> + let f (Diff { field = field'; new_ }) = + f + (Diff + { + field = Field.Cons (field, Field.Opt_map field'); + new_ = Some new_; + }) + in + (helper [@tailcall]) c0 c1 spec f acc) + | Many ls -> List.fold_left (fun acc l -> helper v0 v1 l f acc) acc ls + in + fun v0 v1 spec -> helper v0 v1 spec Fun.id [] + +let apply : type a. a -> a t -> a = + fun v (Diff { field; new_ }) -> Field.set v field new_ + +let apply_all : type a. a -> a t list -> a = + fun v ds -> List.fold_left apply v ds diff --git a/src/main/diff.mli b/src/main/diff.mli new file mode 100644 index 0000000..a39a8d6 --- /dev/null +++ b/src/main/diff.mli @@ -0,0 +1,109 @@ +module Field : sig + (** This module contains what might be described as faux lenses. This includes support for composition, getting, setting, etc. *) + + type (_, _) t = .. + (** An open type that represents a field on a record. + + For example, + {[ +type t = { + x : int +} + ]} + would be described as [X : (t, int) field]. *) + + type getter = { f : 'a 'b. 'a -> ('a, 'b) t -> 'b option } [@@unboxed] + (** A polymorphic function that returns the field's value from the type. *) + + type setter = { f : 'a 'b. 'a -> ('a, 'b) t -> 'b -> 'a option } [@@unboxed] + (** A polymorphic function that returns the type with the field set to the value. *) + + type error = + | Unknown_field : (_, _) t -> error + | Getter_invalid : (_, _) t -> error + | Setter_invalid : (_, _) t -> error + + exception Diff_field of error + + val name : ('a, 'b) t -> string option + (** [name f] returns the previously registered name for [f], if one exists. *) + + val cons : ('a, 'b) t -> ('b, 'c) t -> ('a, 'c) t + (** [cons l r] is a field that first indexes [l] and then [r]. *) + + val opt_map : ('a, 'b) t -> ('a option, 'b option) t + (** [opt_map f] turns [f] into an optional field. *) + + val opt_bind : ('a, 'b option) t -> ('a option, 'b option) t + (** [opt_map f] monadically binds [f] into an optional field. *) + + val register : ?name:string -> ('a, 'b) t -> getter -> setter -> unit + (** [register ?name field getter setter] registers [getter] and [setter] (and optionally [name]) to [field]. *) + + val pp : Format.formatter -> ('a, 'b) t -> unit + val pp_error : Format.formatter -> error -> unit + + module Infix : sig + val ( --| ) : ('a, 'b) t -> ('b, 'c) t -> ('a, 'c) t + (** [f0 --| f1] is [cons f0 f1]. *) + + val ( ?+ ) : ('a, 'b) t -> ('a option, 'b option) t + (** [?+f] is [opt_map f]. *) + + val ( ?* ) : ('a, 'b option) t -> ('a option, 'b option) t + (** [?*f] is [opt_bind f]. *) + end + + val get : 'a -> ('a, 'b) t -> 'b + (** [get v field] gets [field] from [v], raising [Diff_field error] on exception. *) + + val get_opt : 'a -> ('a, 'b) t -> 'b option + (** [get_opt v field] gets [field] from [v], returning [None] on exception. *) + + val get_res : 'a -> ('a, 'b) t -> ('b, [> `Diff_field of error ]) result + (** [get_opt v field] gets [field] from [v], returning [Error (`Diff_field e)] on exception. *) + + val set : 'a -> ('a, 'b) t -> 'b -> 'a + (** [set v field x] sets [field] in [v] to [x], raising [Diff_field error] on exception *) + + val set_opt : 'a -> ('a, 'b) t -> 'b -> 'a option + (** [set_opt v field x] sets [field] in [v] to [x], returning [None] on exception *) + + val set_res : 'a -> ('a, 'b) t -> 'b -> ('a, [> `Diff_field of error ]) result + (** [set_opt v field x] sets [field] in [v] to [x], returning [Error (`Diff_field e)] on exception *) +end + +type _ spec +(** Specifies how the record should be traversed when a diff is computed. *) + +val leaf : field:('a, 'b) Field.t -> equal:('b -> 'b -> bool) -> 'a spec +(** [leaf ~field ~equal] is a terminal node in the spec tree. + + When computing a diff, the fields are gotten using {!Field.get} and compared with [equal]. + If the values are not equal, the diff includes the new value. *) + +val child : field:('a, 'b) Field.t -> spec:'b spec -> 'a spec +(** [child ~field ~spec] is an intermediate node in the spec tree. + + When computing a diff, the diff for the children is recursively computed. *) + +val opt_child : field:('a, 'b option) Field.t -> spec:'b spec -> 'a spec +(** [opt_child ~field ~spec] is an optional intermediate node in the spec tree. + + When computing a diff, the diff for the children is recursively computed + {i if} the child is present. *) + +val many : 'a spec list -> 'a spec +(** [many specs] combines [specs] into a single spec *) + +(** Represents a difference between two records of the same type. *) +type _ t = Diff : { field : ('a, 'b) Field.t; new_ : 'b } -> 'a t + +val compute : 'a -> 'a -> 'a spec -> 'a t list +(** [compute v0 v1 spec] returns a list of all the differences between [v0] and [v1] using [spec] to traverse the values. *) + +val apply : 'a -> 'a t -> 'a +(** [apply v diff] returns [v] with [diff] applied *) + +val apply_all : 'a -> 'a t list -> 'a +(** [apply_all v diffs] returns [v] with all [diffs] applied *) diff --git a/src/main/dune b/src/main/dune new file mode 100644 index 0000000..4c118cc --- /dev/null +++ b/src/main/dune @@ -0,0 +1,3 @@ +(library + (name diff) + (public_name diff)) diff --git a/src/ppx/dune b/src/ppx/dune new file mode 100644 index 0000000..24b4228 --- /dev/null +++ b/src/ppx/dune @@ -0,0 +1,6 @@ +(library + (name ppx_diff) + (public_name diff.ppx) + (libraries ppxlib) + (ppx_runtime_libraries diff) + (kind ppx_deriver)) diff --git a/src/ppx/ppx_diff.ml b/src/ppx/ppx_diff.ml new file mode 100644 index 0000000..66d1149 --- /dev/null +++ b/src/ppx/ppx_diff.ml @@ -0,0 +1,266 @@ +open Ppxlib +open Ast_builder.Default + +module Utils = struct + let constructor_name_of_field ~field_name ~name = + match name with + | "t" -> String.capitalize_ascii field_name + | _ -> String.capitalize_ascii name ^ "_" ^ field_name + + let getter_name ~name = + match name with "t" -> "getter" | _ -> name ^ "_getter" + + let setter_name ~name = + match name with "t" -> "setter" | _ -> name ^ "_setter" +end + +module Lidents = struct + let field ~loc = { loc; txt = Longident.parse "Diff.Field.t" } + let register ~loc = { loc; txt = Longident.parse "Diff.Field.register" } + let set_name ~loc = { loc; txt = Longident.parse "Diff.Field.set_name" } + let unit ~loc = { loc; txt = Lident "()" } + let option ~loc = { loc; txt = Lident "option" } + let some ~loc = { loc; txt = Lident "Some" } + let none ~loc = { loc; txt = Lident "None" } + let getter ~loc = { loc; txt = Longident.parse "Diff.Field.getter" } + let setter ~loc = { loc; txt = Longident.parse "Diff.Field.setter" } + + let constructor_name ~loc ~name ~field_name = + { txt = Lident (Utils.constructor_name_of_field ~field_name ~name); loc } + + let getter_name ~loc ~name = { txt = Lident (Utils.getter_name ~name); loc } + let setter_name ~loc ~name = { txt = Lident (Utils.setter_name ~name); loc } +end + +module Impl = struct + let generate_pre_attr ~loc = + pstr_attribute ~loc + (attribute ~loc + ~name:{ txt = "ocaml.warning"; loc } + ~payload: + (PStr + [ + pstr_eval ~loc + (pexp_constant ~loc (Pconst_string ("-23-39", loc, None))) + []; + ])) + + let generate_post_attr ~loc = + pstr_attribute ~loc + (attribute ~loc + ~name:{ txt = "ocaml.warning"; loc } + ~payload: + (PStr + [ + pstr_eval ~loc + (pexp_constant ~loc (Pconst_string ("+23+39", loc, None))) + []; + ])) + + let generate_field + ~field: + { pld_name = { txt = field_name; _ }; pld_loc = loc; pld_type = typ; _ } + ~name ~ct = + let txt = Utils.constructor_name_of_field ~field_name ~name in + extension_constructor ~loc ~name:{ txt; loc } + ~kind: + (Pext_decl + ( [], + Pcstr_tuple [], + Some (ptyp_constr ~loc (Lidents.field ~loc) [ ct; typ ]) )) + + let generate_fields ~fields ~name ~loc ~ct = + pstr_typext ~loc + (type_extension ~loc ~path:(Lidents.field ~loc) + ~params: + (List.init 2 (fun _ -> (ptyp_any ~loc, (NoVariance, NoInjectivity)))) + ~constructors: + (List.map (fun field -> generate_field ~name ~field ~ct) fields) + ~private_:Public) + + let generate_getter_case + ~field:{ pld_name = { txt = field_name; _ }; pld_loc = loc; _ } ~name = + case + ~lhs: + (ppat_construct ~loc + (Lidents.constructor_name ~loc ~name ~field_name) + None) + ~guard:None + ~rhs: + (pexp_construct ~loc (Lidents.some ~loc) + (Some + (pexp_field ~loc + (pexp_ident ~loc { txt = Lident name; loc }) + { txt = Lident field_name; loc }))) + + let generate_getter_cases ~fields ~loc ~name = + List.rev + (case ~lhs:(ppat_any ~loc) ~guard:None + ~rhs:(pexp_construct ~loc (Lidents.none ~loc) None) + :: List.rev_map (fun field -> generate_getter_case ~field ~name) fields) + + let generate_getter ~fields ~name ~loc = + value_binding ~loc + ~pat: + (ppat_constraint ~loc + (ppat_var ~loc { txt = Utils.getter_name ~name; loc }) + (ptyp_constr ~loc (Lidents.getter ~loc) [])) + ~expr: + (pexp_record ~loc + [ + ( { txt = Lident "f"; loc }, + pexp_newtype ~loc { txt = "a"; loc } + (pexp_newtype ~loc { txt = "b"; loc } + (pexp_fun ~loc Nolabel None + (ppat_constraint ~loc + (ppat_var ~loc { txt = name; loc }) + (ptyp_constr ~loc { txt = Lident "a"; loc } [])) + (pexp_fun ~loc Nolabel None + (ppat_constraint ~loc + (ppat_var ~loc { txt = "__field"; loc }) + (ptyp_constr ~loc (Lidents.field ~loc) + [ + ptyp_constr ~loc { txt = Lident "a"; loc } []; + ptyp_constr ~loc { txt = Lident "b"; loc } []; + ])) + (pexp_constraint ~loc + (pexp_match ~loc + (pexp_ident ~loc + { txt = Lident "__field"; loc }) + (generate_getter_cases ~loc ~fields ~name)) + (ptyp_constr ~loc (Lidents.option ~loc) + [ + ptyp_constr ~loc { txt = Lident "b"; loc } []; + ]))))) ); + ] + None) + + let generate_setter_case + ~field:{ pld_name = { txt = field_name; _ }; pld_loc = loc; _ } ~name = + case + ~lhs: + (ppat_construct ~loc + { + txt = Lident (Utils.constructor_name_of_field ~field_name ~name); + loc; + } + None) + ~guard:None + ~rhs: + (pexp_construct ~loc (Lidents.some ~loc) + (Some + (pexp_record ~loc + [ + ( { txt = Lident field_name; loc }, + pexp_ident ~loc { txt = Lident "__v"; loc } ); + ] + (Some (pexp_ident ~loc { txt = Lident name; loc }))))) + + let generate_setter_cases ~fields ~loc ~name = + List.rev + (case ~lhs:(ppat_any ~loc) ~guard:None + ~rhs:(pexp_construct ~loc (Lidents.none ~loc) None) + :: List.rev_map (fun field -> generate_setter_case ~field ~name) fields) + + let generate_setter ~fields ~name ~loc = + value_binding ~loc + ~pat: + (ppat_constraint ~loc + (ppat_var ~loc { txt = Utils.setter_name ~name; loc }) + (ptyp_constr ~loc (Lidents.setter ~loc) [])) + ~expr: + (pexp_record ~loc + [ + ( { txt = Lident "f"; loc }, + pexp_newtype ~loc { txt = "a"; loc } + (pexp_newtype ~loc { txt = "b"; loc } + (pexp_fun ~loc Nolabel None + (ppat_constraint ~loc + (ppat_var ~loc { txt = name; loc }) + (ptyp_constr ~loc { txt = Lident "a"; loc } [])) + (pexp_fun ~loc Nolabel None + (ppat_constraint ~loc + (ppat_var ~loc { txt = "__field"; loc }) + (ptyp_constr ~loc (Lidents.field ~loc) + [ + ptyp_constr ~loc { txt = Lident "a"; loc } []; + ptyp_constr ~loc { txt = Lident "b"; loc } []; + ])) + (pexp_fun ~loc Nolabel None + (ppat_constraint ~loc + (ppat_var ~loc { txt = "__v"; loc }) + (ptyp_constr ~loc { txt = Lident "b"; loc } [])) + (pexp_constraint ~loc + (pexp_match ~loc + (pexp_ident ~loc + { txt = Lident "__field"; loc }) + (generate_setter_cases ~loc ~fields ~name)) + (ptyp_constr ~loc (Lidents.option ~loc) + [ + ptyp_constr ~loc { txt = Lident "a"; loc } + []; + ])))))) ); + ] + None) + + let generate_register ~fields ~name ~loc = + pstr_value ~loc Nonrecursive + (List.map + (fun { pld_name = { txt = field_name; _ }; pld_loc = loc; _ } -> + let constructor_name = + Utils.constructor_name_of_field ~field_name ~name + in + value_binding ~loc + ~pat: + (ppat_constraint ~loc (ppat_any ~loc) + (ptyp_constr ~loc { txt = Lident "unit"; loc } [])) + ~expr: + (pexp_apply ~loc + (pexp_ident ~loc (Lidents.register ~loc)) + [ + ( Labelled "name", + pexp_constant ~loc + (Pconst_string (constructor_name, loc, None)) ); + ( Nolabel, + pexp_construct ~loc + { txt = Lident constructor_name; loc } + None ); + (Nolabel, pexp_ident ~loc (Lidents.getter_name ~loc ~name)); + (Nolabel, pexp_ident ~loc (Lidents.setter_name ~loc ~name)); + ])) + fields) + + let generate_getter_and_setter ~fields ~name ~loc = + pstr_value ~loc Nonrecursive + [ generate_getter ~fields ~name ~loc; generate_setter ~fields ~name ~loc ] + + let generate ~ctxt:_ (_rec_flag, type_declarations) = + List.fold_left + (fun acc -> function + | { + ptype_kind = Ptype_abstract | Ptype_variant _ | Ptype_open; + ptype_loc = loc; + _; + } -> + let ext = + Location.error_extensionf ~loc + "Cannot derive diffs for non-record types" + in + pstr_extension ~loc ext [] :: acc + | { + ptype_kind = Ptype_record fields; + ptype_loc = loc; + ptype_name = { txt = name; _ }; + _; + } as td -> + let ct = core_type_of_type_declaration td in + generate_pre_attr ~loc + :: generate_fields ~fields ~loc ~name ~ct + :: generate_getter_and_setter ~fields ~name ~loc + :: generate_register ~fields ~name ~loc + :: generate_post_attr ~loc :: acc) + [] type_declarations +end + +let str_type_decl = Deriving.Generator.V2.make_noarg Impl.generate +let deriver = Deriving.add "diff" ~str_type_decl diff --git a/test/diff_test.ml b/test/diff_test.ml new file mode 100644 index 0000000..39fed55 --- /dev/null +++ b/test/diff_test.ml @@ -0,0 +1,84 @@ +module T = Tezt +open T.Base +open Test_utils + +let () = + T.Test.register ~__FILE__ ~title:"compute diff with single field" + ~tags:[ "diff" ] + @@ fun () -> + let open struct + type t = { i : int } [@@deriving diff, show, eq] + end in + let typ = Tezt.Check.equalable pp equal in + let spec = Diff.leaf ~field:I ~equal:Int.equal in + let t0 = { i = 123 } in + let t1 = { i = 456 } in + let diff = Diff.compute t0 t1 spec in + let fields = List.map field_from_diff diff in + let expected = [ F I ] in + T.Check.( + (fields = expected) ~__LOC__ + (list (field ())) + ~error_msg:"expected field %R in diff, got %L"); + let t0' = Diff.apply_all t0 diff in + T.Check.( + (t0' = t1) ~__LOC__ typ + ~error_msg:"expected t0 to be %R after diff application"); + unit + +let () = + T.Test.register ~__FILE__ ~title:"compute diff with multiple levels" + ~tags:[ "diff"; "nested" ] + @@ fun () -> + let open struct + type x = { i : int } + and y = { x : x; j : float } [@@deriving diff, show, eq] + end in + let typ = Tezt.Check.equalable pp_y equal_y in + let x_spec = Diff.leaf ~field:X_i ~equal:Int.equal in + let y_spec = + Diff.( + many [ leaf ~field:Y_j ~equal:Float.equal; child ~field:Y_x ~spec:x_spec ]) + in + let y0 = { j = 1.0; x = { i = 1 } } in + let y1 = { j = 2.0; x = { i = 2 } } in + let diff = Diff.compute y0 y1 y_spec in + let fields = List.map field_from_diff diff in + let expected = Diff.Field.Infix.[ F (Y_x --| X_i); F Y_j ] in + T.Check.( + (fields = expected) ~__LOC__ + (list (field ())) + ~error_msg:"expected field %R in diff, got %L"); + let y0' = Diff.apply_all y0 diff in + T.Check.( + (y0' = y1) ~__LOC__ typ + ~error_msg:"expected t0 to be %R after diff application"); + unit + +let () = + T.Test.register ~__FILE__ ~title:"compute diff with optional child" + ~tags:[ "diff"; "nested" ] + @@ fun () -> + let open struct + type x = { i : int } + and y = { x : x option } + and z = { y : y option } [@@deriving diff, show, eq] + end in + let typ = Tezt.Check.equalable pp_z equal_z in + let x_spec = Diff.leaf ~field:X_i ~equal:Int.equal in + let y_spec = Diff.opt_child ~field:Y_x ~spec:x_spec in + let z_spec = Diff.opt_child ~field:Z_y ~spec:y_spec in + let z0 = { y = Some { x = Some { i = 123 } } } in + let z1 = { y = Some { x = Some { i = 456 } } } in + let diff = Diff.compute z0 z1 z_spec in + let fields = List.map field_from_diff diff in + let expected = Diff.Field.Infix.[ F (Z_y --| ?+(Y_x --| ?+X_i)) ] in + T.Check.( + (fields = expected) ~__LOC__ + (list (field ())) + ~error_msg:"expected field %R in diff, got %L"); + let z0' = Diff.apply_all z0 diff in + T.Check.( + (z0' = z1) ~__LOC__ typ + ~error_msg:"expected z0 to be %R after diff application"); + unit diff --git a/test/dune b/test/dune new file mode 100644 index 0000000..42cff5a --- /dev/null +++ b/test/dune @@ -0,0 +1,5 @@ +(test + (name test) + (libraries diff tezt) + (preprocess + (pps diff.ppx ppx_deriving.show ppx_deriving.eq))) diff --git a/test/field_test.ml b/test/field_test.ml new file mode 100644 index 0000000..b2d6627 --- /dev/null +++ b/test/field_test.ml @@ -0,0 +1,100 @@ +module T = Tezt +open T.Base +open Test_utils + +let () = + T.Test.register ~__FILE__ ~title:"get field" ~tags:[ "field"; "get" ] + @@ fun () -> + let open struct + type t = { i : int } [@@deriving diff] + end in + let t = { i = 123 } in + let v = Diff.Field.get t I in + T.Check.((v = 123) ~__LOC__ int ~error_msg:"expected t.i = %R, got %L"); + unit + +let () = + T.Test.register ~__FILE__ ~title:"set field" ~tags:[ "field"; "set" ] + @@ fun () -> + let open struct + type t = { i : int } [@@deriving diff] + end in + let t = { i = 0 } in + let t' = Diff.Field.set t I 123 in + T.Check.((t'.i = 123) ~__LOC__ int ~error_msg:"expected t.i = %R, got %L"); + unit + +let () = + T.Test.register ~__FILE__ ~title:"get nested field" + ~tags:[ "field"; "get"; "nested" ] + @@ fun () -> + let open struct + type x = { i : int } + and y = { x : x } [@@deriving diff] + end in + let f = Diff.Field.Infix.(Y_x --| X_i) in + let y = { x = { i = 123 } } in + let v = Diff.Field.get y f in + T.Check.((v = 123) ~__LOC__ int ~error_msg:"expected y.x.i = %R, got %L"); + unit + +let () = + T.Test.register ~__FILE__ ~title:"set nested field" + ~tags:[ "field"; "set"; "nested" ] + @@ fun () -> + let open struct + type x = { i : int } + and y = { x : x } [@@deriving diff] + end in + let f = Diff.Field.Infix.(Y_x --| X_i) in + let y = { x = { i = 0 } } in + let y' = Diff.Field.set y f 123 in + T.Check.((y'.x.i = 123) ~__LOC__ int ~error_msg:"expected y.x.i = %R, got %L"); + unit + +let () = + T.Test.register ~__FILE__ ~title:"get field from optional child" + ~tags:[ "field"; "get"; "nested"; "optional" ] + @@ fun () -> + let open struct + type x = { i : int } + and y = { x : x option } [@@deriving diff] + end in + let f = Diff.Field.Infix.(Y_x --| ?+X_i) in + let y = { x = Some { i = 123 } } in + let v = Diff.Field.get y f in + T.Check.( + (v = Some 123) ~__LOC__ (option int) + ~error_msg:"expected y.x.i = %R, got %L"); + unit + +let () = + T.Test.register ~__FILE__ ~title:"get optional field from optional child" + ~tags:[ "field"; "get"; "nested"; "optional" ] + @@ fun () -> + let open struct + type x = { i : int option } + and y = { x : x option } [@@deriving diff] + end in + let f = Diff.Field.Infix.(Y_x --| ?*X_i) in + let y = { x = Some { i = Some 123 } } in + let v = Diff.Field.get y f in + T.Check.( + (v = Some 123) ~__LOC__ (option int) + ~error_msg:"expected y.x.i = %R, got %L"); + unit + +let () = + T.Test.register ~__FILE__ ~title:"getting unregistered field should fail" + ~tags:[ "field"; "get"; "failure" ] + @@ fun () -> + let open struct + type (_, _) Diff.Field.t += Unregistered : (int, string) Diff.Field.t + end in + let res = Diff.Field.get_res 1 Unregistered in + T.Check.( + (res = Error (`Diff_field (Diff.Field.Unknown_field Unregistered))) + ~__LOC__ + (result string field_error) + ~error_msg:"expected error %R, got %L"); + unit diff --git a/test/test.ml b/test/test.ml new file mode 100644 index 0000000..2496022 --- /dev/null +++ b/test/test.ml @@ -0,0 +1,4 @@ +open! Field_test +open! Diff_test + +let () = Tezt.Test.run () diff --git a/test/test_utils.ml b/test/test_utils.ml new file mode 100644 index 0000000..a11c9c2 --- /dev/null +++ b/test/test_utils.ml @@ -0,0 +1,15 @@ +type 'a field = F : ('a, _) Diff.Field.t -> 'a field + +let field () = Tezt.Check.equalable (fun fmt (F f) -> Diff.Field.pp fmt f) ( = ) +let field_from_diff (Diff.Diff { field; _ }) = F field + +let field_error : [ `Diff_field of Diff.Field.error ] Tezt.Check.typ = + Tezt.Check.equalable + (fun fmt (`Diff_field e) -> Diff.Field.pp_error fmt e) + ( = ) + +let result ok error = + Tezt.Check.( + convert + (function Ok v -> (Some v, None) | Error e -> (None, Some e)) + (tuple2 (option ok) (option error)))