From 767501be68d77c0554449c175b82d5acb3811d7d Mon Sep 17 00:00:00 2001 From: aya Date: Wed, 22 Dec 2021 16:01:34 -0500 Subject: [PATCH 01/49] add starter code for make deriver --- dune-project | 1 + src/dune | 3 + src/ppx_make.ml | 205 +++++++++++++++++++++++++++++++++++++++ test/deriving_inline.ml | 11 +++ test/deriving_inline.mli | 12 +++ test/dune | 2 + 6 files changed, 234 insertions(+) create mode 100644 dune-project create mode 100644 src/dune create mode 100644 src/ppx_make.ml create mode 100644 test/deriving_inline.ml create mode 100644 test/deriving_inline.mli create mode 100644 test/dune diff --git a/dune-project b/dune-project new file mode 100644 index 0000000..c994249 --- /dev/null +++ b/dune-project @@ -0,0 +1 @@ +(lang dune 2.9) diff --git a/src/dune b/src/dune new file mode 100644 index 0000000..6f3b8df --- /dev/null +++ b/src/dune @@ -0,0 +1,3 @@ +(library (name ppx_make) + (kind ppx_deriver) (ppx_runtime_libraries fieldslib) (libraries base ppxlib) + (preprocess (pps ppxlib.metaquot))) diff --git a/src/ppx_make.ml b/src/ppx_make.ml new file mode 100644 index 0000000..cb4f9d9 --- /dev/null +++ b/src/ppx_make.ml @@ -0,0 +1,205 @@ +(* Generated code should depend on the environment in scope as little as + possible. E.g. rather than [foo = []] do [match foo with [] ->], to eliminate the + use of [=]. It is especially important to not use polymorphic comparisons, since we + are moving more and more to code that doesn't have them in scope. *) + + open Base + open Ppxlib + open Ast_builder.Default + + let check_no_collision = + let always = [ "create" ] in + fun (lbls : label_declaration list) -> + let generated_funs = + let extra_forbidden_names = + List.filter_map lbls ~f:(function + | { pld_mutable = Mutable; pld_name; _ } -> Some ("set_" ^ pld_name.txt) + | _ -> None) + in + ("set_all_mutable_fields" :: extra_forbidden_names) @ always + in + List.iter lbls ~f:(fun { pld_name; pld_loc; _ } -> + if List.mem generated_funs pld_name.txt ~equal:String.equal + then + Location.raise_errorf + ~loc:pld_loc + "ppx_fields_conv: field name %S conflicts with one of the generated functions" + pld_name.txt) + ;; + + module A = struct + (* Additional AST construction helpers *) + + let str_item ~loc name body = + pstr_value ~loc Nonrecursive [ value_binding ~loc ~pat:(pvar ~loc name) ~expr:body ] + ;; + + let sig_item ~loc name typ = + psig_value + ~loc + (value_description ~loc ~name:(Located.mk ~loc name) ~type_:typ ~prim:[]) + ;; + end + + module Create = struct + let record ~loc pairs = + pexp_record + ~loc + (List.map pairs ~f:(fun (name, exp) -> Located.lident ~loc name, exp)) + None + ;; + + let lambda ~loc patterns body = + List.fold_right patterns ~init:body ~f:(fun (lab, pat) acc -> + pexp_fun ~loc lab None pat acc) + ;; + + let lambda_sig ~loc arg_tys body_ty = + List.fold_right arg_tys ~init:body_ty ~f:(fun (lab, arg_ty) acc -> + ptyp_arrow ~loc lab arg_ty acc) + ;; + end + + module Inspect = struct + let field_names labdecs = List.map labdecs ~f:(fun labdec -> labdec.pld_name.txt) + end + + let check_at_least_one_record ~loc rec_flag tds = + (match rec_flag with + | Nonrecursive -> + Location.raise_errorf ~loc "nonrec is not compatible with the `fields' preprocessor" + | _ -> ()); + let is_record td = + match td.ptype_kind with + | Ptype_record _ -> true + | _ -> false + in + if not (List.exists tds ~f:is_record) + then + Location.raise_errorf + ~loc + (match tds with + | [ _ ] -> "Unsupported use of fields (you can only use it on records)." + | _ -> + "'with fields' can only be applied on type definitions in which at least one \ + type definition is a record") + ;; + + module Gen_sig = struct + let apply_type ~loc ~ty_name ~tps = ptyp_constr ~loc (Located.lident ~loc ty_name) tps + let label_arg name ty = Labelled name, ty + + let create_fun ~ty_name ~tps ~loc labdecs = + let record = apply_type ~loc ~ty_name ~tps in + let f labdec = + let { pld_name = name; pld_type = ty; _ } = labdec in + label_arg name.txt ty + in + let types = List.map labdecs ~f in + let t = Create.lambda_sig ~loc types record in + A.sig_item ~loc "create" t + ;; + + let record + ~private_ + ~ty_name + ~tps + ~loc + (labdecs : label_declaration list) + : signature + = + let create_fun = create_fun ~ty_name ~tps ~loc labdecs in + (match private_ with + (* The ['perm] phantom type prohibits first-class fields from mutating or + creating private records, so we can expose them (and fold, etc.). + + However, we still can't expose functions that explicitly create private + records. *) + | Private -> [] + | Public -> [ create_fun ]) + ;; + + let create_of_td (td : type_declaration) : signature = + let { ptype_name = { txt = ty_name; loc } + ; ptype_private = private_ + ; ptype_params + ; ptype_kind + ; _ + } + = + td + in + let tps = List.map ptype_params ~f:(fun (tp, _variance) -> tp) in + match ptype_kind with + | Ptype_record labdecs -> + check_no_collision labdecs; + record ~private_ ~ty_name ~tps ~loc labdecs + | _ -> [] + ;; + + let generate ~loc ~path:_ (rec_flag, tds) = + check_at_least_one_record ~loc rec_flag tds; + List.concat_map tds ~f:(create_of_td) + ;; + end + + module Gen_struct = struct + let label_arg ?label ~loc name = + let l = + match label with + | None -> name + | Some n -> n + in + Labelled l, pvar ~loc name + ;; + + let creation_fun ~loc _record_name labdecs = + let names = Inspect.field_names labdecs in + let f = Create.record ~loc (List.map names ~f:(fun n -> n, evar ~loc n)) in + let patterns = List.map names ~f:(fun x -> label_arg ~loc x) in + let f = Create.lambda ~loc patterns f in + A.str_item ~loc "create" f + ;; + + let record + ~private_ + ~record_name + ~loc + (labdecs : label_declaration list) + : structure + = + let create = creation_fun ~loc record_name labdecs in + (match private_ with + | Private -> [] + | Public -> [ create ]) + ;; + + let create_of_td (td : type_declaration) : structure = + let { ptype_name = { txt = record_name; loc } + ; ptype_private = private_ + ; ptype_kind + ; _ + } + = + td + in + match ptype_kind with + | Ptype_record labdecs -> + check_no_collision labdecs; + record ~private_ ~record_name ~loc labdecs + | _ -> [] + ;; + + let generate ~loc ~path:_ (rec_flag, tds) = + check_at_least_one_record ~loc rec_flag tds; + List.concat_map tds ~f:(create_of_td) + ;; + end + + let create = + Deriving.add "create" + ~str_type_decl: + (Deriving.Generator.make_noarg Gen_struct.generate) + ~sig_type_decl:(Deriving.Generator.make_noarg Gen_sig.generate) + ;; + \ No newline at end of file diff --git a/test/deriving_inline.ml b/test/deriving_inline.ml new file mode 100644 index 0000000..8da3397 --- /dev/null +++ b/test/deriving_inline.ml @@ -0,0 +1,11 @@ +type t = + { x : int + ; mutable y : bool + } +[@@deriving_inline create] + +let _ = fun (_ : t) -> () +let create ~x ~y = { x; y } +let _ = create + +[@@@end] diff --git a/test/deriving_inline.mli b/test/deriving_inline.mli new file mode 100644 index 0000000..8121fa1 --- /dev/null +++ b/test/deriving_inline.mli @@ -0,0 +1,12 @@ +type t = + { x : int + ; mutable y : bool + } +[@@deriving_inline create] + +include sig [@@@ocaml.warning "-32"] + val create : x:int -> y:bool -> t +end +[@@ocaml.doc "@inline"] + +[@@@end] diff --git a/test/dune b/test/dune new file mode 100644 index 0000000..d745484 --- /dev/null +++ b/test/dune @@ -0,0 +1,2 @@ +(library (name ppx_test) (inline_tests) (libraries fieldslib) + (preprocess (pps ppx_make ppx_inline_test))) From a929c74f6cb5c5753d877e5c78160108b4ff4876 Mon Sep 17 00:00:00 2001 From: aya Date: Thu, 23 Dec 2021 10:17:37 -0500 Subject: [PATCH 02/49] move into new folders --- src/{ => make}/dune | 0 src/{ => make}/ppx_make.ml | 10 ++++++++++ test/{ => make}/deriving_inline.ml | 0 test/{ => make}/deriving_inline.mli | 0 test/{ => make}/dune | 0 5 files changed, 10 insertions(+) rename src/{ => make}/dune (100%) rename src/{ => make}/ppx_make.ml (95%) rename test/{ => make}/deriving_inline.ml (100%) rename test/{ => make}/deriving_inline.mli (100%) rename test/{ => make}/dune (100%) diff --git a/src/dune b/src/make/dune similarity index 100% rename from src/dune rename to src/make/dune diff --git a/src/ppx_make.ml b/src/make/ppx_make.ml similarity index 95% rename from src/ppx_make.ml rename to src/make/ppx_make.ml index cb4f9d9..6680f63 100644 --- a/src/ppx_make.ml +++ b/src/make/ppx_make.ml @@ -34,6 +34,16 @@ pstr_value ~loc Nonrecursive [ value_binding ~loc ~pat:(pvar ~loc name) ~expr:body ] ;; + (* let mod_ ~loc : string -> structure -> structure_item = + fun name structure -> + pstr_module + ~loc + (module_binding + ~loc + ~name:(Located.mk ~loc (Some name)) + ~expr:(pmod_structure ~loc structure)) + ;; *) + let sig_item ~loc name typ = psig_value ~loc diff --git a/test/deriving_inline.ml b/test/make/deriving_inline.ml similarity index 100% rename from test/deriving_inline.ml rename to test/make/deriving_inline.ml diff --git a/test/deriving_inline.mli b/test/make/deriving_inline.mli similarity index 100% rename from test/deriving_inline.mli rename to test/make/deriving_inline.mli diff --git a/test/dune b/test/make/dune similarity index 100% rename from test/dune rename to test/make/dune From 8a801f741daf9c99d78773c1541ae96c68c18bae Mon Sep 17 00:00:00 2001 From: aya Date: Tue, 28 Dec 2021 13:37:17 -0500 Subject: [PATCH 03/49] change function name to make_t + update tests --- src/make/ppx_make.ml | 18 ++++++++++-------- test/make/deriving_inline.ml | 13 ++++++++++--- test/make/deriving_inline.mli | 15 +++++++++++---- 3 files changed, 31 insertions(+), 15 deletions(-) diff --git a/src/make/ppx_make.ml b/src/make/ppx_make.ml index 6680f63..b77d936 100644 --- a/src/make/ppx_make.ml +++ b/src/make/ppx_make.ml @@ -107,7 +107,8 @@ in let types = List.map labdecs ~f in let t = Create.lambda_sig ~loc types record in - A.sig_item ~loc "create" t + let fun_name = "make_" ^ ty_name in + A.sig_item ~loc fun_name t ;; let record @@ -163,12 +164,13 @@ Labelled l, pvar ~loc name ;; - let creation_fun ~loc _record_name labdecs = + let creation_fun ~loc record_name labdecs = let names = Inspect.field_names labdecs in let f = Create.record ~loc (List.map names ~f:(fun n -> n, evar ~loc n)) in let patterns = List.map names ~f:(fun x -> label_arg ~loc x) in let f = Create.lambda ~loc patterns f in - A.str_item ~loc "create" f + let fun_name = "make_" ^ record_name in + A.str_item ~loc fun_name f ;; let record @@ -205,11 +207,11 @@ List.concat_map tds ~f:(create_of_td) ;; end - + let create = - Deriving.add "create" + Deriving.add "create" ~str_type_decl: - (Deriving.Generator.make_noarg Gen_struct.generate) - ~sig_type_decl:(Deriving.Generator.make_noarg Gen_sig.generate) + (Deriving.Generator.make_noarg Gen_struct.generate) + ~sig_type_decl: + (Deriving.Generator.make_noarg Gen_sig.generate) ;; - \ No newline at end of file diff --git a/test/make/deriving_inline.ml b/test/make/deriving_inline.ml index 8da3397..fcb1542 100644 --- a/test/make/deriving_inline.ml +++ b/test/make/deriving_inline.ml @@ -1,11 +1,18 @@ type t = { x : int ; mutable y : bool + ; z: r + } +and r = + { a: t + ; b: bool } [@@deriving_inline create] let _ = fun (_ : t) -> () -let create ~x ~y = { x; y } -let _ = create - +let _ = fun (_ : r) -> () +let make_t ~x ~y ~z = { x; y; z } +let _ = make_t +let make_r ~a ~b = { a; b } +let _ = make_r [@@@end] diff --git a/test/make/deriving_inline.mli b/test/make/deriving_inline.mli index 8121fa1..6cc4ae3 100644 --- a/test/make/deriving_inline.mli +++ b/test/make/deriving_inline.mli @@ -1,12 +1,19 @@ type t = { x : int ; mutable y : bool + ; z: r + } +and r = + { a: t + ; b: bool } [@@deriving_inline create] -include sig [@@@ocaml.warning "-32"] - val create : x:int -> y:bool -> t -end -[@@ocaml.doc "@inline"] +include + sig + [@@@ocaml.warning "-32"] + val make_t : x:int -> y:bool -> z:r -> t + val make_r : a:t -> b:bool -> r + end[@@ocaml.doc "@inline"] [@@@end] From cfd403cf97590ba7a4cfd8287dba8ede5763a315 Mon Sep 17 00:00:00 2001 From: aya Date: Tue, 28 Dec 2021 13:57:08 -0500 Subject: [PATCH 04/49] replace `create` with `make` --- src/make/ppx_make.ml | 26 +++++++++++++------------- test/make/deriving_inline.ml | 2 +- test/make/deriving_inline.mli | 2 +- 3 files changed, 15 insertions(+), 15 deletions(-) diff --git a/src/make/ppx_make.ml b/src/make/ppx_make.ml index b77d936..21f3870 100644 --- a/src/make/ppx_make.ml +++ b/src/make/ppx_make.ml @@ -8,7 +8,7 @@ open Ast_builder.Default let check_no_collision = - let always = [ "create" ] in + let always = [ "make" ] in fun (lbls : label_declaration list) -> let generated_funs = let extra_forbidden_names = @@ -99,7 +99,7 @@ let apply_type ~loc ~ty_name ~tps = ptyp_constr ~loc (Located.lident ~loc ty_name) tps let label_arg name ty = Labelled name, ty - let create_fun ~ty_name ~tps ~loc labdecs = + let make_fun ~ty_name ~tps ~loc labdecs = let record = apply_type ~loc ~ty_name ~tps in let f labdec = let { pld_name = name; pld_type = ty; _ } = labdec in @@ -119,7 +119,7 @@ (labdecs : label_declaration list) : signature = - let create_fun = create_fun ~ty_name ~tps ~loc labdecs in + let make_fun = make_fun ~ty_name ~tps ~loc labdecs in (match private_ with (* The ['perm] phantom type prohibits first-class fields from mutating or creating private records, so we can expose them (and fold, etc.). @@ -127,10 +127,10 @@ However, we still can't expose functions that explicitly create private records. *) | Private -> [] - | Public -> [ create_fun ]) + | Public -> [ make_fun ]) ;; - let create_of_td (td : type_declaration) : signature = + let make_of_td (td : type_declaration) : signature = let { ptype_name = { txt = ty_name; loc } ; ptype_private = private_ ; ptype_params @@ -150,7 +150,7 @@ let generate ~loc ~path:_ (rec_flag, tds) = check_at_least_one_record ~loc rec_flag tds; - List.concat_map tds ~f:(create_of_td) + List.concat_map tds ~f:(make_of_td) ;; end @@ -164,7 +164,7 @@ Labelled l, pvar ~loc name ;; - let creation_fun ~loc record_name labdecs = + let make_fun ~loc record_name labdecs = let names = Inspect.field_names labdecs in let f = Create.record ~loc (List.map names ~f:(fun n -> n, evar ~loc n)) in let patterns = List.map names ~f:(fun x -> label_arg ~loc x) in @@ -180,13 +180,13 @@ (labdecs : label_declaration list) : structure = - let create = creation_fun ~loc record_name labdecs in + let make = make_fun ~loc record_name labdecs in (match private_ with | Private -> [] - | Public -> [ create ]) + | Public -> [ make ]) ;; - let create_of_td (td : type_declaration) : structure = + let make_of_td (td : type_declaration) : structure = let { ptype_name = { txt = record_name; loc } ; ptype_private = private_ ; ptype_kind @@ -204,12 +204,12 @@ let generate ~loc ~path:_ (rec_flag, tds) = check_at_least_one_record ~loc rec_flag tds; - List.concat_map tds ~f:(create_of_td) + List.concat_map tds ~f:(make_of_td) ;; end - let create = - Deriving.add "create" + let make = + Deriving.add "make" ~str_type_decl: (Deriving.Generator.make_noarg Gen_struct.generate) ~sig_type_decl: diff --git a/test/make/deriving_inline.ml b/test/make/deriving_inline.ml index fcb1542..a183111 100644 --- a/test/make/deriving_inline.ml +++ b/test/make/deriving_inline.ml @@ -7,7 +7,7 @@ and r = { a: t ; b: bool } -[@@deriving_inline create] +[@@deriving_inline make] let _ = fun (_ : t) -> () let _ = fun (_ : r) -> () diff --git a/test/make/deriving_inline.mli b/test/make/deriving_inline.mli index 6cc4ae3..f6c9441 100644 --- a/test/make/deriving_inline.mli +++ b/test/make/deriving_inline.mli @@ -7,7 +7,7 @@ and r = { a: t ; b: bool } -[@@deriving_inline create] +[@@deriving_inline make] include sig From 8f1564f0d833353a990be354cb647b102fad6eb1 Mon Sep 17 00:00:00 2001 From: aya Date: Tue, 28 Dec 2021 15:18:34 -0500 Subject: [PATCH 05/49] add tests --- src/make/ppx_make.ml | 6 ++-- test/make/deriving_inline.ml | 52 +++++++++++++++++++++++++++-------- test/make/deriving_inline.mli | 39 +++++++++++++++++++------- 3 files changed, 73 insertions(+), 24 deletions(-) diff --git a/src/make/ppx_make.ml b/src/make/ppx_make.ml index 21f3870..14f76ed 100644 --- a/src/make/ppx_make.ml +++ b/src/make/ppx_make.ml @@ -23,7 +23,7 @@ then Location.raise_errorf ~loc:pld_loc - "ppx_fields_conv: field name %S conflicts with one of the generated functions" + "ppx_make: field name %S conflicts with one of the generated functions" pld_name.txt) ;; @@ -77,7 +77,7 @@ let check_at_least_one_record ~loc rec_flag tds = (match rec_flag with | Nonrecursive -> - Location.raise_errorf ~loc "nonrec is not compatible with the `fields' preprocessor" + Location.raise_errorf ~loc "nonrec is not compatible with the `make' preprocessor" | _ -> ()); let is_record td = match td.ptype_kind with @@ -89,7 +89,7 @@ Location.raise_errorf ~loc (match tds with - | [ _ ] -> "Unsupported use of fields (you can only use it on records)." + | [ _ ] -> "Unsupported use of make (you can only use it on records)." | _ -> "'with fields' can only be applied on type definitions in which at least one \ type definition is a record") diff --git a/test/make/deriving_inline.ml b/test/make/deriving_inline.ml index a183111..0b20133 100644 --- a/test/make/deriving_inline.ml +++ b/test/make/deriving_inline.ml @@ -1,18 +1,48 @@ -type t = +(* Test 1: regular record type *) +type a = + { x : int + ; y : bool + } +[@@deriving_inline make] + +let _ = fun (_ : a) -> () +let make_a ~x ~y = { x; y } +let _ = make_a +[@@@end] + +(* Test 2: recursive record types *) +type b = + { v : c + ; w : bool + } +and c = { x : int ; mutable y : bool - ; z: r + ; z : b } -and r = - { a: t - ; b: bool +[@@deriving_inline make] + +let _ = fun (_ : b) -> () +let _ = fun (_ : c) -> () +let make_b ~v ~w = { v; w } +let _ = make_b +let make_c ~x ~y ~z = { x; y; z } +let _ = make_c +[@@@end] + +(* Test 3: invalid non-record type *) +(* type d = int * int +[@@deriving_inline make] +[@@@end] *) + +(* Test 4: record type unexposed in interface *) +type e = + { x : int + ; y : string } [@@deriving_inline make] -let _ = fun (_ : t) -> () -let _ = fun (_ : r) -> () -let make_t ~x ~y ~z = { x; y; z } -let _ = make_t -let make_r ~a ~b = { a; b } -let _ = make_r +let _ = fun (_ : e) -> () +let make_e ~x ~y = { x; y } +let _ = make_e [@@@end] diff --git a/test/make/deriving_inline.mli b/test/make/deriving_inline.mli index f6c9441..dfe9029 100644 --- a/test/make/deriving_inline.mli +++ b/test/make/deriving_inline.mli @@ -1,19 +1,38 @@ -type t = +(* Test 1: regular record type *) +type a = { x : int - ; mutable y : bool - ; z: r + ; y : bool } -and r = - { a: t - ; b: bool +[@@deriving_inline make] + +include + sig + [@@@ocaml.warning "-32"] + val make_a : x:int -> y:bool -> a + end [@@ocaml.doc "@inline"] +[@@@end] + +(* Test 2: recursive record types *) +type b = + { v : c + ; w : bool + } +and c = + { x : int + ; mutable y : bool + ; z : b } [@@deriving_inline make] include sig [@@@ocaml.warning "-32"] - val make_t : x:int -> y:bool -> z:r -> t - val make_r : a:t -> b:bool -> r - end[@@ocaml.doc "@inline"] - + val make_b : v:c -> w:bool -> b + val make_c : x:int -> y:bool -> z:b -> c + end [@@ocaml.doc "@inline"] [@@@end] + +(* Test 3: invalid non-record type *) +(* type d = int * int +[@@deriving_inline make] +[@@@end] *) From 381edb6dbc0933507541a5777b9f7b97c9a4cbff Mon Sep 17 00:00:00 2001 From: aya Date: Wed, 29 Dec 2021 17:20:46 -0500 Subject: [PATCH 06/49] remove dependency on base + rename for readability --- src/make/ppx_make.ml | 103 +++++++++++++++---------------------------- 1 file changed, 35 insertions(+), 68 deletions(-) diff --git a/src/make/ppx_make.ml b/src/make/ppx_make.ml index 14f76ed..1d9558f 100644 --- a/src/make/ppx_make.ml +++ b/src/make/ppx_make.ml @@ -1,49 +1,18 @@ (* Generated code should depend on the environment in scope as little as possible. E.g. rather than [foo = []] do [match foo with [] ->], to eliminate the - use of [=]. It is especially important to not use polymorphic comparisons, since we - are moving more and more to code that doesn't have them in scope. *) + use of [=], which might be overwritten in the environment. + It is especially important to not use polymorphic comparisons. *) - open Base open Ppxlib open Ast_builder.Default - let check_no_collision = - let always = [ "make" ] in - fun (lbls : label_declaration list) -> - let generated_funs = - let extra_forbidden_names = - List.filter_map lbls ~f:(function - | { pld_mutable = Mutable; pld_name; _ } -> Some ("set_" ^ pld_name.txt) - | _ -> None) - in - ("set_all_mutable_fields" :: extra_forbidden_names) @ always - in - List.iter lbls ~f:(fun { pld_name; pld_loc; _ } -> - if List.mem generated_funs pld_name.txt ~equal:String.equal - then - Location.raise_errorf - ~loc:pld_loc - "ppx_make: field name %S conflicts with one of the generated functions" - pld_name.txt) - ;; - - module A = struct + module Construct = struct (* Additional AST construction helpers *) let str_item ~loc name body = pstr_value ~loc Nonrecursive [ value_binding ~loc ~pat:(pvar ~loc name) ~expr:body ] ;; - (* let mod_ ~loc : string -> structure -> structure_item = - fun name structure -> - pstr_module - ~loc - (module_binding - ~loc - ~name:(Located.mk ~loc (Some name)) - ~expr:(pmod_structure ~loc structure)) - ;; *) - let sig_item ~loc name typ = psig_value ~loc @@ -55,23 +24,23 @@ let record ~loc pairs = pexp_record ~loc - (List.map pairs ~f:(fun (name, exp) -> Located.lident ~loc name, exp)) + (List.map (fun (name, exp) -> Located.lident ~loc name, exp) pairs) None ;; let lambda ~loc patterns body = - List.fold_right patterns ~init:body ~f:(fun (lab, pat) acc -> - pexp_fun ~loc lab None pat acc) + List.fold_right (fun (lab, pat) acc -> + pexp_fun ~loc lab None pat acc) patterns body ;; let lambda_sig ~loc arg_tys body_ty = - List.fold_right arg_tys ~init:body_ty ~f:(fun (lab, arg_ty) acc -> - ptyp_arrow ~loc lab arg_ty acc) + List.fold_right (fun (lab, arg_ty) acc -> + ptyp_arrow ~loc lab arg_ty acc) arg_tys body_ty ;; end module Inspect = struct - let field_names labdecs = List.map labdecs ~f:(fun labdec -> labdec.pld_name.txt) + let field_names label_decls = List.map (fun label_decl -> label_decl.pld_name.txt) label_decls end let check_at_least_one_record ~loc rec_flag tds = @@ -84,7 +53,7 @@ | Ptype_record _ -> true | _ -> false in - if not (List.exists tds ~f:is_record) + if not (List.exists is_record tds) then Location.raise_errorf ~loc @@ -99,27 +68,27 @@ let apply_type ~loc ~ty_name ~tps = ptyp_constr ~loc (Located.lident ~loc ty_name) tps let label_arg name ty = Labelled name, ty - let make_fun ~ty_name ~tps ~loc labdecs = + let make_fun ~ty_name ~tps ~loc label_decls = let record = apply_type ~loc ~ty_name ~tps in - let f labdec = - let { pld_name = name; pld_type = ty; _ } = labdec in + let derive_type label_decl = + let { pld_name = name; pld_type = ty; _ } = label_decl in label_arg name.txt ty in - let types = List.map labdecs ~f in + let types = List.map derive_type label_decls in let t = Create.lambda_sig ~loc types record in let fun_name = "make_" ^ ty_name in - A.sig_item ~loc fun_name t + Construct.sig_item ~loc fun_name t ;; - + let record ~private_ ~ty_name ~tps ~loc - (labdecs : label_declaration list) + (label_decls : label_declaration list) : signature = - let make_fun = make_fun ~ty_name ~tps ~loc labdecs in + let make_fun = make_fun ~ty_name ~tps ~loc label_decls in (match private_ with (* The ['perm] phantom type prohibits first-class fields from mutating or creating private records, so we can expose them (and fold, etc.). @@ -130,7 +99,7 @@ | Public -> [ make_fun ]) ;; - let make_of_td (td : type_declaration) : signature = + let derive_per_td (td : type_declaration) : signature = let { ptype_name = { txt = ty_name; loc } ; ptype_private = private_ ; ptype_params @@ -140,17 +109,16 @@ = td in - let tps = List.map ptype_params ~f:(fun (tp, _variance) -> tp) in + let tps = List.map (fun (tp, _variance) -> tp) ptype_params in match ptype_kind with - | Ptype_record labdecs -> - check_no_collision labdecs; - record ~private_ ~ty_name ~tps ~loc labdecs + | Ptype_record label_decls -> + record ~private_ ~ty_name ~tps ~loc label_decls | _ -> [] ;; let generate ~loc ~path:_ (rec_flag, tds) = check_at_least_one_record ~loc rec_flag tds; - List.concat_map tds ~f:(make_of_td) + List.concat_map (derive_per_td) tds ;; end @@ -164,29 +132,29 @@ Labelled l, pvar ~loc name ;; - let make_fun ~loc record_name labdecs = - let names = Inspect.field_names labdecs in - let f = Create.record ~loc (List.map names ~f:(fun n -> n, evar ~loc n)) in - let patterns = List.map names ~f:(fun x -> label_arg ~loc x) in - let f = Create.lambda ~loc patterns f in + let make_fun ~loc record_name label_decls = + let names = Inspect.field_names label_decls in + let create_record = Create.record ~loc (List.map (fun n -> n, evar ~loc n) names) in + let patterns = List.map (fun x -> label_arg ~loc x) names in + let derive_lambda = Create.lambda ~loc patterns create_record in let fun_name = "make_" ^ record_name in - A.str_item ~loc fun_name f + Construct.str_item ~loc fun_name derive_lambda ;; let record ~private_ ~record_name ~loc - (labdecs : label_declaration list) + (label_decls : label_declaration list) : structure = - let make = make_fun ~loc record_name labdecs in + let make = make_fun ~loc record_name label_decls in (match private_ with | Private -> [] | Public -> [ make ]) ;; - let make_of_td (td : type_declaration) : structure = + let derive_per_td (td : type_declaration) : structure = let { ptype_name = { txt = record_name; loc } ; ptype_private = private_ ; ptype_kind @@ -196,15 +164,14 @@ td in match ptype_kind with - | Ptype_record labdecs -> - check_no_collision labdecs; - record ~private_ ~record_name ~loc labdecs + | Ptype_record label_decls -> + record ~private_ ~record_name ~loc label_decls | _ -> [] ;; let generate ~loc ~path:_ (rec_flag, tds) = check_at_least_one_record ~loc rec_flag tds; - List.concat_map tds ~f:(make_of_td) + List.concat_map (derive_per_td) tds ;; end From 8a2c7e8cae0601d4aa7f6b00c6b135b3c5985705 Mon Sep 17 00:00:00 2001 From: aya Date: Thu, 6 Jan 2022 14:20:47 -0500 Subject: [PATCH 07/49] redo tests using cram and remove old tests --- dune-project | 1 + src/make/dune | 2 +- test/make/deriving_inline.ml | 48 ----------- test/make/deriving_inline.mli | 38 --------- test/make/driver.ml | 1 + test/make/dune | 8 +- test/make/run.t | 152 ++++++++++++++++++++++++++++++++++ 7 files changed, 161 insertions(+), 89 deletions(-) delete mode 100644 test/make/deriving_inline.ml delete mode 100644 test/make/deriving_inline.mli create mode 100644 test/make/driver.ml create mode 100644 test/make/run.t diff --git a/dune-project b/dune-project index c994249..ae73029 100644 --- a/dune-project +++ b/dune-project @@ -1 +1,2 @@ (lang dune 2.9) +(cram enable) diff --git a/src/make/dune b/src/make/dune index 6f3b8df..5f96808 100644 --- a/src/make/dune +++ b/src/make/dune @@ -1,3 +1,3 @@ (library (name ppx_make) - (kind ppx_deriver) (ppx_runtime_libraries fieldslib) (libraries base ppxlib) + (kind ppx_deriver) (ppx_runtime_libraries fieldslib) (libraries ppxlib) (preprocess (pps ppxlib.metaquot))) diff --git a/test/make/deriving_inline.ml b/test/make/deriving_inline.ml deleted file mode 100644 index 0b20133..0000000 --- a/test/make/deriving_inline.ml +++ /dev/null @@ -1,48 +0,0 @@ -(* Test 1: regular record type *) -type a = - { x : int - ; y : bool - } -[@@deriving_inline make] - -let _ = fun (_ : a) -> () -let make_a ~x ~y = { x; y } -let _ = make_a -[@@@end] - -(* Test 2: recursive record types *) -type b = - { v : c - ; w : bool - } -and c = - { x : int - ; mutable y : bool - ; z : b - } -[@@deriving_inline make] - -let _ = fun (_ : b) -> () -let _ = fun (_ : c) -> () -let make_b ~v ~w = { v; w } -let _ = make_b -let make_c ~x ~y ~z = { x; y; z } -let _ = make_c -[@@@end] - -(* Test 3: invalid non-record type *) -(* type d = int * int -[@@deriving_inline make] -[@@@end] *) - -(* Test 4: record type unexposed in interface *) -type e = - { x : int - ; y : string - } -[@@deriving_inline make] - -let _ = fun (_ : e) -> () -let make_e ~x ~y = { x; y } -let _ = make_e -[@@@end] diff --git a/test/make/deriving_inline.mli b/test/make/deriving_inline.mli deleted file mode 100644 index dfe9029..0000000 --- a/test/make/deriving_inline.mli +++ /dev/null @@ -1,38 +0,0 @@ -(* Test 1: regular record type *) -type a = - { x : int - ; y : bool - } -[@@deriving_inline make] - -include - sig - [@@@ocaml.warning "-32"] - val make_a : x:int -> y:bool -> a - end [@@ocaml.doc "@inline"] -[@@@end] - -(* Test 2: recursive record types *) -type b = - { v : c - ; w : bool - } -and c = - { x : int - ; mutable y : bool - ; z : b - } -[@@deriving_inline make] - -include - sig - [@@@ocaml.warning "-32"] - val make_b : v:c -> w:bool -> b - val make_c : x:int -> y:bool -> z:b -> c - end [@@ocaml.doc "@inline"] -[@@@end] - -(* Test 3: invalid non-record type *) -(* type d = int * int -[@@deriving_inline make] -[@@@end] *) diff --git a/test/make/driver.ml b/test/make/driver.ml new file mode 100644 index 0000000..e3cba40 --- /dev/null +++ b/test/make/driver.ml @@ -0,0 +1 @@ +let () = Ppxlib.Driver.standalone () diff --git a/test/make/dune b/test/make/dune index d745484..97c2bd2 100644 --- a/test/make/dune +++ b/test/make/dune @@ -1,2 +1,6 @@ -(library (name ppx_test) (inline_tests) (libraries fieldslib) - (preprocess (pps ppx_make ppx_inline_test))) +(executable + (name driver) + (libraries ppx_make ppxlib)) + +(cram + (deps driver.exe)) diff --git a/test/make/run.t b/test/make/run.t new file mode 100644 index 0000000..6d25ce9 --- /dev/null +++ b/test/make/run.t @@ -0,0 +1,152 @@ +------------------------------------------------- +-----------------STRUCTURE TESTS----------------- +------------------------------------------------- +Test 1: regular record type + $ test1=" + > type a = { + > x: int ; + > y: bool }[@@deriving make]" + $ echo "$test1" > test.ml + $ ./driver.exe test.ml + type a = { + x: int ; + y: bool }[@@deriving make] + include + struct + let _ = fun (_ : a) -> () + let make_a ~x ~y = { x; y } + let _ = make_a + end[@@ocaml.doc "@inline"][@@merlin.hide ] + +Test 2: unexposed regular record type + $ test4=" + > type b = { + > x : int ; + > y : string }[@@deriving make]" + $ echo "$test2" > test.ml + $ ./driver.exe test.ml + +Test 3: invalid non-record type + $ test3=" + > type c = int * int + > [@@deriving make]" + $ echo "$test3" > test.ml + $ ./driver.exe test.ml + File "test.ml", lines 2-3, characters 0-17: + 2 | type c = int * int + 3 | [@@deriving make] + Error: Unsupported use of make (you can only use it on records). + [1] + +Test 4: recursive record types + $ test4=" + > type d = { + > v: e ; + > w: bool } + > and e = { + > x: int ; + > mutable y: bool ; + > z: d }[@@deriving make]" + $ echo "$test4" > test.ml + $ ./driver.exe test.ml + type d = { + v: e ; + w: bool } + and e = { + x: int ; + mutable y: bool ; + z: d }[@@deriving make] + include + struct + let _ = fun (_ : d) -> () + let _ = fun (_ : e) -> () + let make_d ~v ~w = { v; w } + let _ = make_d + let make_e ~x ~y ~z = { x; y; z } + let _ = make_e + end[@@ocaml.doc "@inline"][@@merlin.hide ] + +Test 5: recursive types including a record type + $ test5=" + > type f = int*g + > and g = { + > v: f ; + > w: bool }[@@deriving make]" + $ echo "$test5" > test.ml + $ ./driver.exe test.ml + type f = (int * g) + and g = { + v: f ; + w: bool }[@@deriving make] + include + struct + let _ = fun (_ : f) -> () + let _ = fun (_ : g) -> () + let make_g ~v ~w = { v; w } + let _ = make_g + end[@@ocaml.doc "@inline"][@@merlin.hide ] + +Test 6: recursive types without any record types + $ test6=" + > type f = int*g + > and g = bool*f [@@deriving make]" + $ echo "$test6" > test.ml + $ ./driver.exe test.ml + File "test.ml", lines 2-3, characters 0-32: + 2 | type f = int*g + 3 | and g = bool*f [@@deriving make] + Error: 'with fields' can only be applied on type definitions in which at least one type definition is a record + [1] + +------------------------------------------------- +------------------INLINE TESTS------------------- +------------------------------------------------- +Test 1: regular record type + $ test1=" + > type a = { + > x: int ; + > y: bool }[@@deriving make]" + $ echo "$test1" > test.mli + $ ./driver.exe test.mli + type a = { + x: int ; + y: bool }[@@deriving make] + include sig [@@@ocaml.warning "-32"] val make_a : x:int -> y:bool -> a end + [@@ocaml.doc "@inline"][@@merlin.hide ] + +Test 2: invalid non-record type + $ test2=" + > type c = int * int + > [@@deriving make]" + $ echo "$test2" > test.mli + $ ./driver.exe test.mli + File "test.mli", lines 2-3, characters 0-17: + 2 | type c = int * int + 3 | [@@deriving make] + Error: Unsupported use of make (you can only use it on records). + [1] + +Test 3: recursive record types + $ test3=" + > type d = { + > v: e ; + > w: bool } + > and e = { + > x: int ; + > mutable y: bool ; + > z: d }[@@deriving make]" + $ echo "$test3" > test.mli + $ ./driver.exe test.mli + type d = { + v: e ; + w: bool } + and e = { + x: int ; + mutable y: bool ; + z: d }[@@deriving make] + include + sig + [@@@ocaml.warning "-32"] + val make_d : v:e -> w:bool -> d + val make_e : x:int -> y:bool -> z:d -> e + end[@@ocaml.doc "@inline"][@@merlin.hide ] From 7c0e2d9bfc77e9376b7933f8c1761de608b04f4c Mon Sep 17 00:00:00 2001 From: aya Date: Fri, 7 Jan 2022 17:53:32 -0500 Subject: [PATCH 08/49] separate str and sig tests into new subfolders --- test/make/{ => signature}/driver.ml | 0 test/make/{ => signature}/dune | 0 test/make/signature/run.t | 49 ++++++++++++++++++++ test/make/structure/driver.ml | 1 + test/make/structure/dune | 6 +++ test/make/{ => structure}/run.t | 71 ++--------------------------- 6 files changed, 61 insertions(+), 66 deletions(-) rename test/make/{ => signature}/driver.ml (100%) rename test/make/{ => signature}/dune (100%) create mode 100644 test/make/signature/run.t create mode 100644 test/make/structure/driver.ml create mode 100644 test/make/structure/dune rename test/make/{ => structure}/run.t (54%) diff --git a/test/make/driver.ml b/test/make/signature/driver.ml similarity index 100% rename from test/make/driver.ml rename to test/make/signature/driver.ml diff --git a/test/make/dune b/test/make/signature/dune similarity index 100% rename from test/make/dune rename to test/make/signature/dune diff --git a/test/make/signature/run.t b/test/make/signature/run.t new file mode 100644 index 0000000..73c1752 --- /dev/null +++ b/test/make/signature/run.t @@ -0,0 +1,49 @@ +Test 1: regular record type + $ test1=" + > type a = { + > x: int ; + > y: bool }[@@deriving make]" + $ echo "$test1" > test.mli + $ ./driver.exe test.mli + type a = { + x: int ; + y: bool }[@@deriving make] + include sig [@@@ocaml.warning "-32"] val make_a : x:int -> y:bool -> a end + [@@ocaml.doc "@inline"][@@merlin.hide ] + +Test 2: invalid non-record type + $ test2=" + > type c = int * int + > [@@deriving make]" + $ echo "$test2" > test.mli + $ ./driver.exe test.mli + File "test.mli", lines 2-3, characters 0-17: + 2 | type c = int * int + 3 | [@@deriving make] + Error: Unsupported use of make (you can only use it on records). + [1] + +Test 3: recursive record types + $ test3=" + > type d = { + > v: e ; + > w: bool } + > and e = { + > x: int ; + > mutable y: bool ; + > z: d }[@@deriving make]" + $ echo "$test3" > test.mli + $ ./driver.exe test.mli + type d = { + v: e ; + w: bool } + and e = { + x: int ; + mutable y: bool ; + z: d }[@@deriving make] + include + sig + [@@@ocaml.warning "-32"] + val make_d : v:e -> w:bool -> d + val make_e : x:int -> y:bool -> z:d -> e + end[@@ocaml.doc "@inline"][@@merlin.hide ] diff --git a/test/make/structure/driver.ml b/test/make/structure/driver.ml new file mode 100644 index 0000000..e3cba40 --- /dev/null +++ b/test/make/structure/driver.ml @@ -0,0 +1 @@ +let () = Ppxlib.Driver.standalone () diff --git a/test/make/structure/dune b/test/make/structure/dune new file mode 100644 index 0000000..97c2bd2 --- /dev/null +++ b/test/make/structure/dune @@ -0,0 +1,6 @@ +(executable + (name driver) + (libraries ppx_make ppxlib)) + +(cram + (deps driver.exe)) diff --git a/test/make/run.t b/test/make/structure/run.t similarity index 54% rename from test/make/run.t rename to test/make/structure/run.t index 6d25ce9..b8a37fd 100644 --- a/test/make/run.t +++ b/test/make/structure/run.t @@ -1,7 +1,6 @@ -------------------------------------------------- ------------------STRUCTURE TESTS----------------- -------------------------------------------------- -Test 1: regular record type +general comment on iclude let _ +are generated by ppxlib +Test 1: For a regular record type $ test1=" > type a = { > x: int ; @@ -18,15 +17,7 @@ Test 1: regular record type let _ = make_a end[@@ocaml.doc "@inline"][@@merlin.hide ] -Test 2: unexposed regular record type - $ test4=" - > type b = { - > x : int ; - > y : string }[@@deriving make]" - $ echo "$test2" > test.ml - $ ./driver.exe test.ml - -Test 3: invalid non-record type +Test 3: expect an error because make cannot be derived for non-record types $ test3=" > type c = int * int > [@@deriving make]" @@ -39,6 +30,7 @@ Test 3: invalid non-record type [1] Test 4: recursive record types +we expect to hve 1 make function sfor each record type in the recursive type declaration $ test4=" > type d = { > v: e ; @@ -97,56 +89,3 @@ Test 6: recursive types without any record types 3 | and g = bool*f [@@deriving make] Error: 'with fields' can only be applied on type definitions in which at least one type definition is a record [1] - -------------------------------------------------- -------------------INLINE TESTS------------------- -------------------------------------------------- -Test 1: regular record type - $ test1=" - > type a = { - > x: int ; - > y: bool }[@@deriving make]" - $ echo "$test1" > test.mli - $ ./driver.exe test.mli - type a = { - x: int ; - y: bool }[@@deriving make] - include sig [@@@ocaml.warning "-32"] val make_a : x:int -> y:bool -> a end - [@@ocaml.doc "@inline"][@@merlin.hide ] - -Test 2: invalid non-record type - $ test2=" - > type c = int * int - > [@@deriving make]" - $ echo "$test2" > test.mli - $ ./driver.exe test.mli - File "test.mli", lines 2-3, characters 0-17: - 2 | type c = int * int - 3 | [@@deriving make] - Error: Unsupported use of make (you can only use it on records). - [1] - -Test 3: recursive record types - $ test3=" - > type d = { - > v: e ; - > w: bool } - > and e = { - > x: int ; - > mutable y: bool ; - > z: d }[@@deriving make]" - $ echo "$test3" > test.mli - $ ./driver.exe test.mli - type d = { - v: e ; - w: bool } - and e = { - x: int ; - mutable y: bool ; - z: d }[@@deriving make] - include - sig - [@@@ocaml.warning "-32"] - val make_d : v:e -> w:bool -> d - val make_e : x:int -> y:bool -> z:d -> e - end[@@ocaml.doc "@inline"][@@merlin.hide ] From 51efc166a4bd640d23184a81187789cf97fcbc39 Mon Sep 17 00:00:00 2001 From: aya Date: Fri, 7 Jan 2022 17:54:20 -0500 Subject: [PATCH 09/49] rename functions and edit error msgs --- src/make/ppx_make.ml | 33 +++++++++++++++------------------ 1 file changed, 15 insertions(+), 18 deletions(-) diff --git a/src/make/ppx_make.ml b/src/make/ppx_make.ml index 1d9558f..3e47358 100644 --- a/src/make/ppx_make.ml +++ b/src/make/ppx_make.ml @@ -46,7 +46,7 @@ let check_at_least_one_record ~loc rec_flag tds = (match rec_flag with | Nonrecursive -> - Location.raise_errorf ~loc "nonrec is not compatible with the `make' preprocessor" + Location.raise_errorf ~loc "nonrec is not compatible with the `make' preprocessor." | _ -> ()); let is_record td = match td.ptype_kind with @@ -60,15 +60,15 @@ (match tds with | [ _ ] -> "Unsupported use of make (you can only use it on records)." | _ -> - "'with fields' can only be applied on type definitions in which at least one \ - type definition is a record") + "make can only be applied on type definitions in which at least one \ + type definition is a record.") ;; - + module Gen_sig = struct let apply_type ~loc ~ty_name ~tps = ptyp_constr ~loc (Located.lident ~loc ty_name) tps let label_arg name ty = Labelled name, ty - let make_fun ~ty_name ~tps ~loc label_decls = + let create_make_fun ~loc ~ty_name ~tps label_decls = let record = apply_type ~loc ~ty_name ~tps in let derive_type label_decl = let { pld_name = name; pld_type = ty; _ } = label_decl in @@ -88,15 +88,12 @@ (label_decls : label_declaration list) : signature = - let make_fun = make_fun ~ty_name ~tps ~loc label_decls in - (match private_ with - (* The ['perm] phantom type prohibits first-class fields from mutating or - creating private records, so we can expose them (and fold, etc.). - - However, we still can't expose functions that explicitly create private - records. *) - | Private -> [] - | Public -> [ make_fun ]) + let derived_item = create_make_fun ~loc ~ty_name ~tps label_decls in + (match private_ with + (* We can't expose functions that explicitly create private + records. *) + | Private -> [] + | Public -> [ derived_item ]) ;; let derive_per_td (td : type_declaration) : signature = @@ -132,7 +129,7 @@ Labelled l, pvar ~loc name ;; - let make_fun ~loc record_name label_decls = + let create_make_fun ~loc ~record_name label_decls = let names = Inspect.field_names label_decls in let create_record = Create.record ~loc (List.map (fun n -> n, evar ~loc n) names) in let patterns = List.map (fun x -> label_arg ~loc x) names in @@ -148,12 +145,12 @@ (label_decls : label_declaration list) : structure = - let make = make_fun ~loc record_name label_decls in + let derived_item = create_make_fun ~loc ~record_name label_decls in (match private_ with | Private -> [] - | Public -> [ make ]) + | Public -> [ derived_item ]) ;; - + let derive_per_td (td : type_declaration) : structure = let { ptype_name = { txt = record_name; loc } ; ptype_private = private_ From 8aa732105c6e03c1cb6000474a0422a6f6ea6391 Mon Sep 17 00:00:00 2001 From: aya Date: Fri, 7 Jan 2022 18:03:16 -0500 Subject: [PATCH 10/49] rename functions and edit error msgs --- src/make/ppx_make.ml | 4 +--- test/make/signature/run.t | 13 +++++++++++++ test/make/structure/run.t | 2 +- 3 files changed, 15 insertions(+), 4 deletions(-) diff --git a/src/make/ppx_make.ml b/src/make/ppx_make.ml index 3e47358..95ac8db 100644 --- a/src/make/ppx_make.ml +++ b/src/make/ppx_make.ml @@ -90,9 +90,7 @@ = let derived_item = create_make_fun ~loc ~ty_name ~tps label_decls in (match private_ with - (* We can't expose functions that explicitly create private - records. *) - | Private -> [] + | Private -> Location.raise_errorf ~loc "We cannot expose functions that explicitly create private records." | Public -> [ derived_item ]) ;; diff --git a/test/make/signature/run.t b/test/make/signature/run.t index 73c1752..ac49e12 100644 --- a/test/make/signature/run.t +++ b/test/make/signature/run.t @@ -47,3 +47,16 @@ Test 3: recursive record types val make_d : v:e -> w:bool -> d val make_e : x:int -> y:bool -> z:d -> e end[@@ocaml.doc "@inline"][@@merlin.hide ] + +Test 4: private type + $ test4=" + > type f = private { + > x: int ; + > y: bool }[@@deriving make]" + $ echo "$test4" > test.mli + $ ./driver.exe test.mli + File "test.mli", line 2, characters 5-6: + 2 | type f = private { + ^ + Error: We cannot expose functions that explicitly create private records. + [1] diff --git a/test/make/structure/run.t b/test/make/structure/run.t index b8a37fd..be3b7cb 100644 --- a/test/make/structure/run.t +++ b/test/make/structure/run.t @@ -87,5 +87,5 @@ Test 6: recursive types without any record types File "test.ml", lines 2-3, characters 0-32: 2 | type f = int*g 3 | and g = bool*f [@@deriving make] - Error: 'with fields' can only be applied on type definitions in which at least one type definition is a record + Error: make can only be applied on type definitions in which at least one type definition is a record. [1] From 4cfb1cb27597fe80a1a6740febab5b82faba203e Mon Sep 17 00:00:00 2001 From: aya Date: Fri, 7 Jan 2022 18:04:47 -0500 Subject: [PATCH 11/49] Revert "rename functions and edit error msgs" This reverts commit 8aa732105c6e03c1cb6000474a0422a6f6ea6391. --- src/make/ppx_make.ml | 4 +++- test/make/signature/run.t | 13 ------------- test/make/structure/run.t | 2 +- 3 files changed, 4 insertions(+), 15 deletions(-) diff --git a/src/make/ppx_make.ml b/src/make/ppx_make.ml index 95ac8db..3e47358 100644 --- a/src/make/ppx_make.ml +++ b/src/make/ppx_make.ml @@ -90,7 +90,9 @@ = let derived_item = create_make_fun ~loc ~ty_name ~tps label_decls in (match private_ with - | Private -> Location.raise_errorf ~loc "We cannot expose functions that explicitly create private records." + (* We can't expose functions that explicitly create private + records. *) + | Private -> [] | Public -> [ derived_item ]) ;; diff --git a/test/make/signature/run.t b/test/make/signature/run.t index ac49e12..73c1752 100644 --- a/test/make/signature/run.t +++ b/test/make/signature/run.t @@ -47,16 +47,3 @@ Test 3: recursive record types val make_d : v:e -> w:bool -> d val make_e : x:int -> y:bool -> z:d -> e end[@@ocaml.doc "@inline"][@@merlin.hide ] - -Test 4: private type - $ test4=" - > type f = private { - > x: int ; - > y: bool }[@@deriving make]" - $ echo "$test4" > test.mli - $ ./driver.exe test.mli - File "test.mli", line 2, characters 5-6: - 2 | type f = private { - ^ - Error: We cannot expose functions that explicitly create private records. - [1] diff --git a/test/make/structure/run.t b/test/make/structure/run.t index be3b7cb..b8a37fd 100644 --- a/test/make/structure/run.t +++ b/test/make/structure/run.t @@ -87,5 +87,5 @@ Test 6: recursive types without any record types File "test.ml", lines 2-3, characters 0-32: 2 | type f = int*g 3 | and g = bool*f [@@deriving make] - Error: make can only be applied on type definitions in which at least one type definition is a record. + Error: 'with fields' can only be applied on type definitions in which at least one type definition is a record [1] From 8ce54f851aef9d4474b10b9e7a0bb8121a1bc161 Mon Sep 17 00:00:00 2001 From: aya Date: Fri, 7 Jan 2022 18:07:18 -0500 Subject: [PATCH 12/49] add error msg for exposing with private types + add corresponding test --- src/make/ppx_make.ml | 4 +--- test/make/signature/run.t | 13 +++++++++++++ test/make/structure/run.t | 2 +- 3 files changed, 15 insertions(+), 4 deletions(-) diff --git a/src/make/ppx_make.ml b/src/make/ppx_make.ml index 3e47358..95ac8db 100644 --- a/src/make/ppx_make.ml +++ b/src/make/ppx_make.ml @@ -90,9 +90,7 @@ = let derived_item = create_make_fun ~loc ~ty_name ~tps label_decls in (match private_ with - (* We can't expose functions that explicitly create private - records. *) - | Private -> [] + | Private -> Location.raise_errorf ~loc "We cannot expose functions that explicitly create private records." | Public -> [ derived_item ]) ;; diff --git a/test/make/signature/run.t b/test/make/signature/run.t index 73c1752..ac49e12 100644 --- a/test/make/signature/run.t +++ b/test/make/signature/run.t @@ -47,3 +47,16 @@ Test 3: recursive record types val make_d : v:e -> w:bool -> d val make_e : x:int -> y:bool -> z:d -> e end[@@ocaml.doc "@inline"][@@merlin.hide ] + +Test 4: private type + $ test4=" + > type f = private { + > x: int ; + > y: bool }[@@deriving make]" + $ echo "$test4" > test.mli + $ ./driver.exe test.mli + File "test.mli", line 2, characters 5-6: + 2 | type f = private { + ^ + Error: We cannot expose functions that explicitly create private records. + [1] diff --git a/test/make/structure/run.t b/test/make/structure/run.t index b8a37fd..be3b7cb 100644 --- a/test/make/structure/run.t +++ b/test/make/structure/run.t @@ -87,5 +87,5 @@ Test 6: recursive types without any record types File "test.ml", lines 2-3, characters 0-32: 2 | type f = int*g 3 | and g = bool*f [@@deriving make] - Error: 'with fields' can only be applied on type definitions in which at least one type definition is a record + Error: make can only be applied on type definitions in which at least one type definition is a record. [1] From dce19b81dad3214305504c9b0034a4227501b635 Mon Sep 17 00:00:00 2001 From: aya Date: Fri, 7 Jan 2022 18:11:02 -0500 Subject: [PATCH 13/49] add test for nonrec type --- test/make/structure/run.t | 14 ++++++++++++++ 1 file changed, 14 insertions(+) diff --git a/test/make/structure/run.t b/test/make/structure/run.t index be3b7cb..440010d 100644 --- a/test/make/structure/run.t +++ b/test/make/structure/run.t @@ -17,6 +17,20 @@ Test 1: For a regular record type let _ = make_a end[@@ocaml.doc "@inline"][@@merlin.hide ] +Test 2: Error msg for nonrec type + $ test2=" + > type nonrec b = { + > x: int ; + > y: bool }[@@deriving make]" + $ echo "$test2" > test.ml + $ ./driver.exe test.ml + File "test.ml", lines 2-4, characters 0-28: + 2 | type nonrec b = { + 3 | x: int ; + 4 | y: bool }[@@deriving make] + Error: nonrec is not compatible with the `make' preprocessor. + [1] + Test 3: expect an error because make cannot be derived for non-record types $ test3=" > type c = int * int From 6160b73432dc1d4fe750926992023e6e7c3f1bfc Mon Sep 17 00:00:00 2001 From: aya Date: Mon, 10 Jan 2022 11:10:09 -0500 Subject: [PATCH 14/49] add test for private types + edit test descriptions --- test/make/signature/run.t | 101 ++++++++++++++++++++++++++++---------- test/make/structure/run.t | 96 +++++++++++++++++++++--------------- 2 files changed, 132 insertions(+), 65 deletions(-) diff --git a/test/make/signature/run.t b/test/make/signature/run.t index ac49e12..b9fe189 100644 --- a/test/make/signature/run.t +++ b/test/make/signature/run.t @@ -1,4 +1,9 @@ -Test 1: regular record type +--------------------------------------------------- +NOTICE: @@ocaml.doc and @@merlin.hide annotations +& `include struct` boilerplate are added by ppxlib. +--------------------------------------------------- + +Test 1: Given a regular record type a, expose make_a $ test1=" > type a = { > x: int ; @@ -11,11 +16,25 @@ Test 1: regular record type include sig [@@@ocaml.warning "-32"] val make_a : x:int -> y:bool -> a end [@@ocaml.doc "@inline"][@@merlin.hide ] -Test 2: invalid non-record type +Test 2: Given a nonrec type, throw error $ test2=" + > type nonrec b = { + > x: int ; + > y: bool }[@@deriving make]" + $ echo "$test2" > test.mli + $ ./driver.exe test.mli + File "test.mli", lines 2-4, characters 0-28: + 2 | type nonrec b = { + 3 | x: int ; + 4 | y: bool }[@@deriving make] + Error: nonrec is not compatible with the `make' preprocessor. + [1] + +Test 3: Given a non-record type, throw error + $ test3=" > type c = int * int > [@@deriving make]" - $ echo "$test2" > test.mli + $ echo "$test3" > test.mli $ ./driver.exe test.mli File "test.mli", lines 2-3, characters 0-17: 2 | type c = int * int @@ -23,40 +42,70 @@ Test 2: invalid non-record type Error: Unsupported use of make (you can only use it on records). [1] -Test 3: recursive record types - $ test3=" - > type d = { - > v: e ; +Test 4: Given a private type, throw error + $ test4=" + > type d = private { + > x: int ; + > y: bool }[@@deriving make]" + $ echo "$test4" > test.mli + $ ./driver.exe test.mli + File "test.mli", line 2, characters 5-6: + 2 | type d = private { + ^ + Error: We cannot expose functions that explicitly create private records. + [1] + +Test 5: Given recursive types which are exclusively +record types, expose 1 make function for each record + $ test5=" + > type e = { + > v: f ; > w: bool } - > and e = { + > and f = { > x: int ; > mutable y: bool ; - > z: d }[@@deriving make]" - $ echo "$test3" > test.mli + > z: e }[@@deriving make]" + $ echo "$test5" > test.mli $ ./driver.exe test.mli - type d = { - v: e ; + type e = { + v: f ; w: bool } - and e = { + and f = { x: int ; mutable y: bool ; - z: d }[@@deriving make] + z: e }[@@deriving make] include sig [@@@ocaml.warning "-32"] - val make_d : v:e -> w:bool -> d - val make_e : x:int -> y:bool -> z:d -> e + val make_e : v:f -> w:bool -> e + val make_f : x:int -> y:bool -> z:e -> f end[@@ocaml.doc "@inline"][@@merlin.hide ] -Test 4: private type - $ test4=" - > type f = private { - > x: int ; - > y: bool }[@@deriving make]" - $ echo "$test4" > test.mli +Test 6: Given recursive types with at least one +record type, expose 1 make function for each type + $ test6=" + > type g = int*h + > and h = { + > v: g ; + > w: bool }[@@deriving make]" + $ echo "$test6" > test.mli $ ./driver.exe test.mli - File "test.mli", line 2, characters 5-6: - 2 | type f = private { - ^ - Error: We cannot expose functions that explicitly create private records. + type g = (int * h) + and h = { + v: g ; + w: bool }[@@deriving make] + include sig [@@@ocaml.warning "-32"] val make_h : v:g -> w:bool -> h end + [@@ocaml.doc "@inline"][@@merlin.hide ] + +Test 7: Given recursive types without any record +types, throw error + $ test7=" + > type i = int*j + > and j = bool*i [@@deriving make]" + $ echo "$test7" > test.mli + $ ./driver.exe test.mli + File "test.mli", lines 2-3, characters 0-32: + 2 | type i = int*j + 3 | and j = bool*i [@@deriving make] + Error: make can only be applied on type definitions in which at least one type definition is a record. [1] diff --git a/test/make/structure/run.t b/test/make/structure/run.t index 440010d..7512603 100644 --- a/test/make/structure/run.t +++ b/test/make/structure/run.t @@ -1,6 +1,9 @@ -general comment on iclude let _ -are generated by ppxlib -Test 1: For a regular record type +--------------------------------------------------- +NOTICE: @@ocaml.doc and @@merlin.hide annotations +& `include struct` boilerplate are added by ppxlib. +--------------------------------------------------- + +Test 1: Given a regular record type a, derive make_a $ test1=" > type a = { > x: int ; @@ -17,7 +20,7 @@ Test 1: For a regular record type let _ = make_a end[@@ocaml.doc "@inline"][@@merlin.hide ] -Test 2: Error msg for nonrec type +Test 2: Given a nonrec type, throw error $ test2=" > type nonrec b = { > x: int ; @@ -31,7 +34,7 @@ Test 2: Error msg for nonrec type Error: nonrec is not compatible with the `make' preprocessor. [1] -Test 3: expect an error because make cannot be derived for non-record types +Test 3: Given a non-record type, throw error $ test3=" > type c = int * int > [@@deriving make]" @@ -43,63 +46,78 @@ Test 3: expect an error because make cannot be derived for non-record types Error: Unsupported use of make (you can only use it on records). [1] -Test 4: recursive record types -we expect to hve 1 make function sfor each record type in the recursive type declaration +Test 4: Given a private record type f, derive make_f $ test4=" - > type d = { - > v: e ; + > type d = private { + > x: int ; + > y: bool }[@@deriving make]" + $ echo "$test4" > test.ml + $ ./driver.exe test.ml + type d = private { + x: int ; + y: bool }[@@deriving make] + include struct let _ = fun (_ : d) -> () end[@@ocaml.doc "@inline"][@@merlin.hide + ] + +Test 5: Given recursive types which are exclusively +record types, derive 1 make function for each record + $ test5=" + > type e = { + > v: f ; > w: bool } - > and e = { + > and f = { > x: int ; > mutable y: bool ; - > z: d }[@@deriving make]" - $ echo "$test4" > test.ml + > z: e }[@@deriving make]" + $ echo "$test5" > test.ml $ ./driver.exe test.ml - type d = { - v: e ; + type e = { + v: f ; w: bool } - and e = { + and f = { x: int ; mutable y: bool ; - z: d }[@@deriving make] + z: e }[@@deriving make] include struct - let _ = fun (_ : d) -> () let _ = fun (_ : e) -> () - let make_d ~v ~w = { v; w } - let _ = make_d - let make_e ~x ~y ~z = { x; y; z } + let _ = fun (_ : f) -> () + let make_e ~v ~w = { v; w } let _ = make_e + let make_f ~x ~y ~z = { x; y; z } + let _ = make_f end[@@ocaml.doc "@inline"][@@merlin.hide ] -Test 5: recursive types including a record type - $ test5=" - > type f = int*g - > and g = { - > v: f ; +Test 6: Given recursive types with at least one +record type, derive one make function for each type + $ test6=" + > type g = int*h + > and h = { + > v: g ; > w: bool }[@@deriving make]" - $ echo "$test5" > test.ml + $ echo "$test6" > test.ml $ ./driver.exe test.ml - type f = (int * g) - and g = { - v: f ; + type g = (int * h) + and h = { + v: g ; w: bool }[@@deriving make] include struct - let _ = fun (_ : f) -> () let _ = fun (_ : g) -> () - let make_g ~v ~w = { v; w } - let _ = make_g + let _ = fun (_ : h) -> () + let make_h ~v ~w = { v; w } + let _ = make_h end[@@ocaml.doc "@inline"][@@merlin.hide ] -Test 6: recursive types without any record types - $ test6=" - > type f = int*g - > and g = bool*f [@@deriving make]" - $ echo "$test6" > test.ml +Test 7: Given recursive types without any record +types, throw error + $ test7=" + > type i = int*j + > and i = bool*j [@@deriving make]" + $ echo "$test7" > test.ml $ ./driver.exe test.ml File "test.ml", lines 2-3, characters 0-32: - 2 | type f = int*g - 3 | and g = bool*f [@@deriving make] + 2 | type i = int*j + 3 | and i = bool*j [@@deriving make] Error: make can only be applied on type definitions in which at least one type definition is a record. [1] From e753f41f40b0fe5e69bcfadf8b6659e8a685537f Mon Sep 17 00:00:00 2001 From: aya Date: Mon, 10 Jan 2022 11:13:50 -0500 Subject: [PATCH 15/49] typo --- test/make/structure/run.t | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test/make/structure/run.t b/test/make/structure/run.t index 7512603..b54f525 100644 --- a/test/make/structure/run.t +++ b/test/make/structure/run.t @@ -46,7 +46,7 @@ Test 3: Given a non-record type, throw error Error: Unsupported use of make (you can only use it on records). [1] -Test 4: Given a private record type f, derive make_f +Test 4: Given a private record type d, derive make_d $ test4=" > type d = private { > x: int ; From 972692d3aa19e34b068d7794c31798929fe9c44f Mon Sep 17 00:00:00 2001 From: aya Date: Tue, 11 Jan 2022 13:53:45 -0500 Subject: [PATCH 16/49] Refactor modules --- src/make/ppx_make.ml | 106 +++++++++++++++++-------------------------- 1 file changed, 42 insertions(+), 64 deletions(-) diff --git a/src/make/ppx_make.ml b/src/make/ppx_make.ml index 95ac8db..81131c2 100644 --- a/src/make/ppx_make.ml +++ b/src/make/ppx_make.ml @@ -1,6 +1,6 @@ (* Generated code should depend on the environment in scope as little as - possible. E.g. rather than [foo = []] do [match foo with [] ->], to eliminate the - use of [=], which might be overwritten in the environment. + possible. E.g. rather than [foo = []] do [match foo with [] ->], to + eliminate the use of [=], which might be overwritten in the environment. It is especially important to not use polymorphic comparisons. *) open Ppxlib @@ -9,38 +9,34 @@ module Construct = struct (* Additional AST construction helpers *) - let str_item ~loc name body = - pstr_value ~loc Nonrecursive [ value_binding ~loc ~pat:(pvar ~loc name) ~expr:body ] - ;; - - let sig_item ~loc name typ = - psig_value - ~loc - (value_description ~loc ~name:(Located.mk ~loc name) ~type_:typ ~prim:[]) - ;; - end - - module Create = struct - let record ~loc pairs = - pexp_record - ~loc - (List.map (fun (name, exp) -> Located.lident ~loc name, exp) pairs) - None + let apply_type ~loc ~ty_name ~tps = + ptyp_constr ~loc (Located.lident ~loc ty_name) tps ;; - + let lambda ~loc patterns body = - List.fold_right (fun (lab, pat) acc -> - pexp_fun ~loc lab None pat acc) patterns body + List.fold_right (fun (lab, pat) acc -> + pexp_fun ~loc lab None pat acc) patterns body ;; - + let lambda_sig ~loc arg_tys body_ty = - List.fold_right (fun (lab, arg_ty) acc -> - ptyp_arrow ~loc lab arg_ty acc) arg_tys body_ty + List.fold_right (fun (lab, arg_ty) acc -> + ptyp_arrow ~loc lab arg_ty acc) arg_tys body_ty + ;; + + let record ~loc pairs = + pexp_record + ~loc + (List.map (fun (name, exp) -> Located.lident ~loc name, exp) pairs) + None + ;; + + let sig_item ~loc name typ = + psig_value ~loc (value_description ~loc ~name:(Located.mk ~loc name) ~type_:typ ~prim:[]) + ;; + + let str_item ~loc name body = + pstr_value ~loc Nonrecursive [ value_binding ~loc ~pat:(pvar ~loc name) ~expr:body ] ;; - end - - module Inspect = struct - let field_names label_decls = List.map (fun label_decl -> label_decl.pld_name.txt) label_decls end let check_at_least_one_record ~loc rec_flag tds = @@ -65,35 +61,25 @@ ;; module Gen_sig = struct - let apply_type ~loc ~ty_name ~tps = ptyp_constr ~loc (Located.lident ~loc ty_name) tps let label_arg name ty = Labelled name, ty let create_make_fun ~loc ~ty_name ~tps label_decls = - let record = apply_type ~loc ~ty_name ~tps in + let record = Construct.apply_type ~loc ~ty_name ~tps in let derive_type label_decl = let { pld_name = name; pld_type = ty; _ } = label_decl in label_arg name.txt ty in let types = List.map derive_type label_decls in - let t = Create.lambda_sig ~loc types record in + let t = Construct.lambda_sig ~loc types record in let fun_name = "make_" ^ ty_name in Construct.sig_item ~loc fun_name t ;; - - let record - ~private_ - ~ty_name - ~tps - ~loc - (label_decls : label_declaration list) - : signature - = - let derived_item = create_make_fun ~loc ~ty_name ~tps label_decls in - (match private_ with - | Private -> Location.raise_errorf ~loc "We cannot expose functions that explicitly create private records." - | Public -> [ derived_item ]) - ;; + let check_public ~private_ ~loc = + (match private_ with + | Private -> Location.raise_errorf ~loc "We cannot expose functions that explicitly create private records." + | Public -> () ) + let derive_per_td (td : type_declaration) : signature = let { ptype_name = { txt = ty_name; loc } ; ptype_private = private_ @@ -107,7 +93,9 @@ let tps = List.map (fun (tp, _variance) -> tp) ptype_params in match ptype_kind with | Ptype_record label_decls -> - record ~private_ ~ty_name ~tps ~loc label_decls + check_public ~private_ ~loc ; + let derived_item = create_make_fun ~loc ~ty_name ~tps label_decls in + [ derived_item ] | _ -> [] ;; @@ -128,26 +116,13 @@ ;; let create_make_fun ~loc ~record_name label_decls = - let names = Inspect.field_names label_decls in - let create_record = Create.record ~loc (List.map (fun n -> n, evar ~loc n) names) in + let names = List.map (fun label_decl -> label_decl.pld_name.txt) label_decls in + let create_record = Construct.record ~loc (List.map (fun n -> n, evar ~loc n) names) in let patterns = List.map (fun x -> label_arg ~loc x) names in - let derive_lambda = Create.lambda ~loc patterns create_record in + let derive_lambda = Construct.lambda ~loc patterns create_record in let fun_name = "make_" ^ record_name in Construct.str_item ~loc fun_name derive_lambda ;; - - let record - ~private_ - ~record_name - ~loc - (label_decls : label_declaration list) - : structure - = - let derived_item = create_make_fun ~loc ~record_name label_decls in - (match private_ with - | Private -> [] - | Public -> [ derived_item ]) - ;; let derive_per_td (td : type_declaration) : structure = let { ptype_name = { txt = record_name; loc } @@ -160,7 +135,10 @@ in match ptype_kind with | Ptype_record label_decls -> - record ~private_ ~record_name ~loc label_decls + (match private_ with + | Private -> [] + | Public -> let derived_item = create_make_fun ~loc ~record_name label_decls in + [ derived_item ]) | _ -> [] ;; From 5d5098c2fe7916e3a8b17b769c57d36ed336a7f5 Mon Sep 17 00:00:00 2001 From: aya Date: Wed, 12 Jan 2022 14:38:24 -0500 Subject: [PATCH 17/49] Change cram test file structure --- test/make/{signature => }/driver.ml | 0 test/make/{signature => }/dune | 6 +++++- test/make/{signature/run.t => signature.t} | 14 +++++++------- test/make/{structure/run.t => structure.t} | 14 +++++++------- test/make/structure/driver.ml | 1 - test/make/structure/dune | 6 ------ 6 files changed, 19 insertions(+), 22 deletions(-) rename test/make/{signature => }/driver.ml (100%) rename test/make/{signature => }/dune (52%) rename test/make/{signature/run.t => signature.t} (94%) rename test/make/{structure/run.t => structure.t} (94%) delete mode 100644 test/make/structure/driver.ml delete mode 100644 test/make/structure/dune diff --git a/test/make/signature/driver.ml b/test/make/driver.ml similarity index 100% rename from test/make/signature/driver.ml rename to test/make/driver.ml diff --git a/test/make/signature/dune b/test/make/dune similarity index 52% rename from test/make/signature/dune rename to test/make/dune index 97c2bd2..08499cb 100644 --- a/test/make/signature/dune +++ b/test/make/dune @@ -2,5 +2,9 @@ (name driver) (libraries ppx_make ppxlib)) +(env + (_ + (binaries driver.exe))) + (cram - (deps driver.exe)) + (deps %{bin:driver})) diff --git a/test/make/signature/run.t b/test/make/signature.t similarity index 94% rename from test/make/signature/run.t rename to test/make/signature.t index b9fe189..9070c59 100644 --- a/test/make/signature/run.t +++ b/test/make/signature.t @@ -9,7 +9,7 @@ Test 1: Given a regular record type a, expose make_a > x: int ; > y: bool }[@@deriving make]" $ echo "$test1" > test.mli - $ ./driver.exe test.mli + $ driver test.mli type a = { x: int ; y: bool }[@@deriving make] @@ -22,7 +22,7 @@ Test 2: Given a nonrec type, throw error > x: int ; > y: bool }[@@deriving make]" $ echo "$test2" > test.mli - $ ./driver.exe test.mli + $ driver test.mli File "test.mli", lines 2-4, characters 0-28: 2 | type nonrec b = { 3 | x: int ; @@ -35,7 +35,7 @@ Test 3: Given a non-record type, throw error > type c = int * int > [@@deriving make]" $ echo "$test3" > test.mli - $ ./driver.exe test.mli + $ driver test.mli File "test.mli", lines 2-3, characters 0-17: 2 | type c = int * int 3 | [@@deriving make] @@ -48,7 +48,7 @@ Test 4: Given a private type, throw error > x: int ; > y: bool }[@@deriving make]" $ echo "$test4" > test.mli - $ ./driver.exe test.mli + $ driver test.mli File "test.mli", line 2, characters 5-6: 2 | type d = private { ^ @@ -66,7 +66,7 @@ record types, expose 1 make function for each record > mutable y: bool ; > z: e }[@@deriving make]" $ echo "$test5" > test.mli - $ ./driver.exe test.mli + $ driver test.mli type e = { v: f ; w: bool } @@ -89,7 +89,7 @@ record type, expose 1 make function for each type > v: g ; > w: bool }[@@deriving make]" $ echo "$test6" > test.mli - $ ./driver.exe test.mli + $ driver test.mli type g = (int * h) and h = { v: g ; @@ -103,7 +103,7 @@ types, throw error > type i = int*j > and j = bool*i [@@deriving make]" $ echo "$test7" > test.mli - $ ./driver.exe test.mli + $ driver test.mli File "test.mli", lines 2-3, characters 0-32: 2 | type i = int*j 3 | and j = bool*i [@@deriving make] diff --git a/test/make/structure/run.t b/test/make/structure.t similarity index 94% rename from test/make/structure/run.t rename to test/make/structure.t index b54f525..535b427 100644 --- a/test/make/structure/run.t +++ b/test/make/structure.t @@ -9,7 +9,7 @@ Test 1: Given a regular record type a, derive make_a > x: int ; > y: bool }[@@deriving make]" $ echo "$test1" > test.ml - $ ./driver.exe test.ml + $ driver test.ml type a = { x: int ; y: bool }[@@deriving make] @@ -26,7 +26,7 @@ Test 2: Given a nonrec type, throw error > x: int ; > y: bool }[@@deriving make]" $ echo "$test2" > test.ml - $ ./driver.exe test.ml + $ driver test.ml File "test.ml", lines 2-4, characters 0-28: 2 | type nonrec b = { 3 | x: int ; @@ -39,7 +39,7 @@ Test 3: Given a non-record type, throw error > type c = int * int > [@@deriving make]" $ echo "$test3" > test.ml - $ ./driver.exe test.ml + $ driver test.ml File "test.ml", lines 2-3, characters 0-17: 2 | type c = int * int 3 | [@@deriving make] @@ -52,7 +52,7 @@ Test 4: Given a private record type d, derive make_d > x: int ; > y: bool }[@@deriving make]" $ echo "$test4" > test.ml - $ ./driver.exe test.ml + $ driver test.ml type d = private { x: int ; y: bool }[@@deriving make] @@ -70,7 +70,7 @@ record types, derive 1 make function for each record > mutable y: bool ; > z: e }[@@deriving make]" $ echo "$test5" > test.ml - $ ./driver.exe test.ml + $ driver test.ml type e = { v: f ; w: bool } @@ -96,7 +96,7 @@ record type, derive one make function for each type > v: g ; > w: bool }[@@deriving make]" $ echo "$test6" > test.ml - $ ./driver.exe test.ml + $ driver test.ml type g = (int * h) and h = { v: g ; @@ -115,7 +115,7 @@ types, throw error > type i = int*j > and i = bool*j [@@deriving make]" $ echo "$test7" > test.ml - $ ./driver.exe test.ml + $ driver test.ml File "test.ml", lines 2-3, characters 0-32: 2 | type i = int*j 3 | and i = bool*j [@@deriving make] diff --git a/test/make/structure/driver.ml b/test/make/structure/driver.ml deleted file mode 100644 index e3cba40..0000000 --- a/test/make/structure/driver.ml +++ /dev/null @@ -1 +0,0 @@ -let () = Ppxlib.Driver.standalone () diff --git a/test/make/structure/dune b/test/make/structure/dune deleted file mode 100644 index 97c2bd2..0000000 --- a/test/make/structure/dune +++ /dev/null @@ -1,6 +0,0 @@ -(executable - (name driver) - (libraries ppx_make ppxlib)) - -(cram - (deps driver.exe)) From 7020222f3aea9664c2f3f4d46697d2cb45d2b5e0 Mon Sep 17 00:00:00 2001 From: aya Date: Wed, 12 Jan 2022 15:44:04 -0500 Subject: [PATCH 18/49] Add changelog --- CHANGES.md | 5 +++++ 1 file changed, 5 insertions(+) create mode 100644 CHANGES.md diff --git a/CHANGES.md b/CHANGES.md new file mode 100644 index 0000000..6f8650c --- /dev/null +++ b/CHANGES.md @@ -0,0 +1,5 @@ +2022-01-XX +----- + +- Adding implementation of first standard deriver, (`make`), along with tests and changelog +- Drafting readme to detail documentation for `make` From 6412e6228228889690b63c66fd08010e5c6172dd Mon Sep 17 00:00:00 2001 From: aya Date: Mon, 31 Jan 2022 11:54:33 -0500 Subject: [PATCH 19/49] Add sig for option fields + refactor --- src/make/ppx_make.ml | 57 ++++++++++++++++++++++++-------------------- 1 file changed, 31 insertions(+), 26 deletions(-) diff --git a/src/make/ppx_make.ml b/src/make/ppx_make.ml index 81131c2..10a3794 100644 --- a/src/make/ppx_make.ml +++ b/src/make/ppx_make.ml @@ -38,32 +38,37 @@ pstr_value ~loc Nonrecursive [ value_binding ~loc ~pat:(pvar ~loc name) ~expr:body ] ;; end - - let check_at_least_one_record ~loc rec_flag tds = - (match rec_flag with - | Nonrecursive -> - Location.raise_errorf ~loc "nonrec is not compatible with the `make' preprocessor." - | _ -> ()); - let is_record td = - match td.ptype_kind with - | Ptype_record _ -> true - | _ -> false - in - if not (List.exists is_record tds) - then - Location.raise_errorf - ~loc - (match tds with - | [ _ ] -> "Unsupported use of make (you can only use it on records)." - | _ -> - "make can only be applied on type definitions in which at least one \ - type definition is a record.") - ;; + + module Check = struct + let derivable ~loc rec_flag tds = + (match rec_flag with + | Nonrecursive -> + Location.raise_errorf ~loc "nonrec is not compatible with the `make' preprocessor." + | _ -> ()); + let is_record td = + match td.ptype_kind with + | Ptype_record _ -> true + | _ -> false + in + if not (List.exists is_record tds) + then + Location.raise_errorf + ~loc + (match tds with + | [ _ ] -> "Unsupported use of make (you can only use it on records)." + | _ -> + "make can only be applied on type definitions in which at least one \ + type definition is a record.") + ;; + end module Gen_sig = struct - let label_arg name ty = Labelled name, ty + let label_arg name ty = match ty with + (* a' option -> ?name , a' *) + | [%type: [%t? a'] option] -> Optional name, a' + | _ -> Labelled name, ty - let create_make_fun ~loc ~ty_name ~tps label_decls = + let create_make_sig ~loc ~ty_name ~tps label_decls = let record = Construct.apply_type ~loc ~ty_name ~tps in let derive_type label_decl = let { pld_name = name; pld_type = ty; _ } = label_decl in @@ -94,13 +99,13 @@ match ptype_kind with | Ptype_record label_decls -> check_public ~private_ ~loc ; - let derived_item = create_make_fun ~loc ~ty_name ~tps label_decls in + let derived_item = create_make_sig ~loc ~ty_name ~tps label_decls in [ derived_item ] | _ -> [] ;; let generate ~loc ~path:_ (rec_flag, tds) = - check_at_least_one_record ~loc rec_flag tds; + Check.derivable ~loc rec_flag tds; List.concat_map (derive_per_td) tds ;; end @@ -143,7 +148,7 @@ ;; let generate ~loc ~path:_ (rec_flag, tds) = - check_at_least_one_record ~loc rec_flag tds; + Check.derivable ~loc rec_flag tds; List.concat_map (derive_per_td) tds ;; end From ec829c672878f5bbfaeff3d65012a4622e885a5b Mon Sep 17 00:00:00 2001 From: aya Date: Mon, 31 Jan 2022 11:55:04 -0500 Subject: [PATCH 20/49] Add option field test --- test/make/signature.t | 14 ++++++++++++++ 1 file changed, 14 insertions(+) diff --git a/test/make/signature.t b/test/make/signature.t index 9070c59..6be16f1 100644 --- a/test/make/signature.t +++ b/test/make/signature.t @@ -109,3 +109,17 @@ types, throw error 3 | and j = bool*i [@@deriving make] Error: make can only be applied on type definitions in which at least one type definition is a record. [1] + +Test 8: Given a record type k with an `option` +field, expose make_k + $ test8=" + > type k = { + > x: int ; + > y: bool option }[@@deriving make]" + $ echo "$test8" > test.mli + $ driver test.mli + type k = { + x: int ; + y: bool option }[@@deriving make] + include sig [@@@ocaml.warning "-32"] val make_k : x:int -> ?y:bool -> k end + [@@ocaml.doc "@inline"][@@merlin.hide ] From 4fd35f77f6df7502e445bc2980ec96621422dcf2 Mon Sep 17 00:00:00 2001 From: aya Date: Tue, 1 Feb 2022 14:45:23 -0500 Subject: [PATCH 21/49] Add unit for option signature --- src/make/ppx_make.ml | 11 ++++++++++- 1 file changed, 10 insertions(+), 1 deletion(-) diff --git a/src/make/ppx_make.ml b/src/make/ppx_make.ml index 10a3794..2c3fc79 100644 --- a/src/make/ppx_make.ml +++ b/src/make/ppx_make.ml @@ -68,6 +68,10 @@ | [%type: [%t? a'] option] -> Optional name, a' | _ -> Labelled name, ty + let change_last_type ~loc types has_option = match has_option with + | true -> types @ [ Nolabel, Ast_helper.Typ.constr ~loc { txt = Lident "unit"; loc } [] ] + | _ -> types + let create_make_sig ~loc ~ty_name ~tps label_decls = let record = Construct.apply_type ~loc ~ty_name ~tps in let derive_type label_decl = @@ -75,6 +79,11 @@ label_arg name.txt ty in let types = List.map derive_type label_decls in + let has_option = List.exists ( fun (name, _) -> match name with + | Optional _ -> true + | _ -> false) types + in + let types = change_last_type ~loc types has_option in let t = Construct.lambda_sig ~loc types record in let fun_name = "make_" ^ ty_name in Construct.sig_item ~loc fun_name t @@ -98,7 +107,7 @@ let tps = List.map (fun (tp, _variance) -> tp) ptype_params in match ptype_kind with | Ptype_record label_decls -> - check_public ~private_ ~loc ; + check_public ~private_ ~loc ; let derived_item = create_make_sig ~loc ~ty_name ~tps label_decls in [ derived_item ] | _ -> [] From 408020cf67994108a2bab8e1a538286ab714084d Mon Sep 17 00:00:00 2001 From: aya Date: Tue, 1 Feb 2022 14:46:19 -0500 Subject: [PATCH 22/49] Fix signature option test --- test/make/signature.t | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/test/make/signature.t b/test/make/signature.t index 6be16f1..6fad62f 100644 --- a/test/make/signature.t +++ b/test/make/signature.t @@ -121,5 +121,6 @@ field, expose make_k type k = { x: int ; y: bool option }[@@deriving make] - include sig [@@@ocaml.warning "-32"] val make_k : x:int -> ?y:bool -> k end + include + sig [@@@ocaml.warning "-32"] val make_k : x:int -> ?y:bool -> unit -> k end [@@ocaml.doc "@inline"][@@merlin.hide ] From e5c5da4c0728a4819ae8cb08d1ae30886be36e91 Mon Sep 17 00:00:00 2001 From: aya Date: Tue, 1 Feb 2022 15:52:57 -0500 Subject: [PATCH 23/49] Add option structure --- src/make/ppx_make.ml | 19 ++++++++----------- 1 file changed, 8 insertions(+), 11 deletions(-) diff --git a/src/make/ppx_make.ml b/src/make/ppx_make.ml index 2c3fc79..e9166a1 100644 --- a/src/make/ppx_make.ml +++ b/src/make/ppx_make.ml @@ -70,7 +70,7 @@ let change_last_type ~loc types has_option = match has_option with | true -> types @ [ Nolabel, Ast_helper.Typ.constr ~loc { txt = Lident "unit"; loc } [] ] - | _ -> types + | false -> types let create_make_sig ~loc ~ty_name ~tps label_decls = let record = Construct.apply_type ~loc ~ty_name ~tps in @@ -120,19 +120,16 @@ end module Gen_struct = struct - let label_arg ?label ~loc name = - let l = - match label with - | None -> name - | Some n -> n - in - Labelled l, pvar ~loc name + let label_arg ~loc name ty = + match ty with + | [%type: [%t? _] option] -> Optional name, pvar ~loc name + | _ -> Labelled name, pvar ~loc name ;; let create_make_fun ~loc ~record_name label_decls = - let names = List.map (fun label_decl -> label_decl.pld_name.txt) label_decls in - let create_record = Construct.record ~loc (List.map (fun n -> n, evar ~loc n) names) in - let patterns = List.map (fun x -> label_arg ~loc x) names in + let names_and_types = List.map (fun label_decl -> label_decl.pld_name.txt, label_decl.pld_type) label_decls in + let create_record = Construct.record ~loc (List.map (fun (n, _) -> n, evar ~loc n) names_and_types) in + let patterns = List.map (fun (n,t) -> label_arg ~loc n t) names_and_types in let derive_lambda = Construct.lambda ~loc patterns create_record in let fun_name = "make_" ^ record_name in Construct.str_item ~loc fun_name derive_lambda From 0aabac04ba2ae20b361a2ebdd87ebf5cd466cb27 Mon Sep 17 00:00:00 2001 From: aya Date: Tue, 1 Feb 2022 15:53:10 -0500 Subject: [PATCH 24/49] Add option structure test --- test/make/structure.t | 18 ++++++++++++++++++ 1 file changed, 18 insertions(+) diff --git a/test/make/structure.t b/test/make/structure.t index 535b427..ce1800c 100644 --- a/test/make/structure.t +++ b/test/make/structure.t @@ -121,3 +121,21 @@ types, throw error 3 | and i = bool*j [@@deriving make] Error: make can only be applied on type definitions in which at least one type definition is a record. [1] + +Test 8: Given a record type k with an `option` +field, derive make_k + $ test8=" + > type k = { + > x: int ; + > y: bool option }[@@deriving make]" + $ echo "$test8" > test.ml + $ driver test.ml + type k = { + x: int ; + y: bool option }[@@deriving make] + include + struct + let _ = fun (_ : k) -> () + let make_k ~x ?y = { x; y } + let _ = make_k + end[@@ocaml.doc "@inline"][@@merlin.hide ] From f49bf39526e86e5a1ab413b9caeeca7ffb824c28 Mon Sep 17 00:00:00 2001 From: aya Date: Tue, 1 Feb 2022 21:17:15 -0500 Subject: [PATCH 25/49] Fix option structure test --- test/make/structure.t | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test/make/structure.t b/test/make/structure.t index ce1800c..a046474 100644 --- a/test/make/structure.t +++ b/test/make/structure.t @@ -136,6 +136,6 @@ field, derive make_k include struct let _ = fun (_ : k) -> () - let make_k ~x ?y = { x; y } + let make_k ~x ?y () = { x; y } let _ = make_k end[@@ocaml.doc "@inline"][@@merlin.hide ] From 71e65fbf80a65bcdd860ba47a9c01cd95ede4e0b Mon Sep 17 00:00:00 2001 From: aya Date: Tue, 1 Feb 2022 21:30:11 -0500 Subject: [PATCH 26/49] Fix option structure + refactor --- src/make/ppx_make.ml | 24 ++++++++++++++++-------- 1 file changed, 16 insertions(+), 8 deletions(-) diff --git a/src/make/ppx_make.ml b/src/make/ppx_make.ml index e9166a1..fd62bba 100644 --- a/src/make/ppx_make.ml +++ b/src/make/ppx_make.ml @@ -60,6 +60,10 @@ "make can only be applied on type definitions in which at least one \ type definition is a record.") ;; + + let has_option labels = List.exists (fun (name, _) -> match name with + | Optional _ -> true + | _ -> false) labels end module Gen_sig = struct @@ -67,10 +71,6 @@ (* a' option -> ?name , a' *) | [%type: [%t? a'] option] -> Optional name, a' | _ -> Labelled name, ty - - let change_last_type ~loc types has_option = match has_option with - | true -> types @ [ Nolabel, Ast_helper.Typ.constr ~loc { txt = Lident "unit"; loc } [] ] - | false -> types let create_make_sig ~loc ~ty_name ~tps label_decls = let record = Construct.apply_type ~loc ~ty_name ~tps in @@ -79,11 +79,14 @@ label_arg name.txt ty in let types = List.map derive_type label_decls in - let has_option = List.exists ( fun (name, _) -> match name with - | Optional _ -> true - | _ -> false) types + let add_unit types = types @ [ + Nolabel, + Ast_helper.Typ.constr ~loc { txt = Lident "unit"; loc } [] + ] in + let types = match Check.has_option types with + | true -> add_unit types + | false -> types in - let types = change_last_type ~loc types has_option in let t = Construct.lambda_sig ~loc types record in let fun_name = "make_" ^ ty_name in Construct.sig_item ~loc fun_name t @@ -130,6 +133,11 @@ let names_and_types = List.map (fun label_decl -> label_decl.pld_name.txt, label_decl.pld_type) label_decls in let create_record = Construct.record ~loc (List.map (fun (n, _) -> n, evar ~loc n) names_and_types) in let patterns = List.map (fun (n,t) -> label_arg ~loc n t) names_and_types in + let add_unit patterns = patterns @ [ Nolabel, punit ~loc ] in + let patterns = match Check.has_option patterns with + | true -> add_unit patterns + | false -> patterns + in let derive_lambda = Construct.lambda ~loc patterns create_record in let fun_name = "make_" ^ record_name in Construct.str_item ~loc fun_name derive_lambda From 0d37ecff77112bf728d5055528cd862f339716a9 Mon Sep 17 00:00:00 2001 From: aya Date: Fri, 4 Feb 2022 15:04:19 -0500 Subject: [PATCH 27/49] Add main annotation for signature --- src/make/dune | 2 +- src/make/ppx_make.ml | 22 ++++++++++++++++++---- 2 files changed, 19 insertions(+), 5 deletions(-) diff --git a/src/make/dune b/src/make/dune index 5f96808..7176be2 100644 --- a/src/make/dune +++ b/src/make/dune @@ -1,3 +1,3 @@ (library (name ppx_make) - (kind ppx_deriver) (ppx_runtime_libraries fieldslib) (libraries ppxlib) + (kind ppx_deriver) (ppx_runtime_libraries fieldslib) (libraries ppxlib ppx_deriving.api) (preprocess (pps ppxlib.metaquot))) diff --git a/src/make/ppx_make.ml b/src/make/ppx_make.ml index fd62bba..6ea61d7 100644 --- a/src/make/ppx_make.ml +++ b/src/make/ppx_make.ml @@ -72,8 +72,20 @@ | [%type: [%t? a'] option] -> Optional name, a' | _ -> Labelled name, ty + let find_main labels = + List.fold_right (fun ({ pld_type; pld_loc; pld_attributes ; _ } as label) (main, labels) -> + if Ppx_deriving.(pld_type.ptyp_attributes @ pld_attributes |> + attr ~deriver:"make" "main" |> Arg.get_flag ~deriver:"make") then + match main with + | Some _ -> Location.raise_errorf ~loc:pld_loc "Duplicate [@deriving.%s.main] annotation" "make" + | None -> Some label, labels + else + main, label :: labels) + labels (None, []) + let create_make_sig ~loc ~ty_name ~tps label_decls = let record = Construct.apply_type ~loc ~ty_name ~tps in + let main, label_decls = find_main label_decls in let derive_type label_decl = let { pld_name = name; pld_type = ty; _ } = label_decl in label_arg name.txt ty @@ -82,10 +94,12 @@ let add_unit types = types @ [ Nolabel, Ast_helper.Typ.constr ~loc { txt = Lident "unit"; loc } [] - ] in - let types = match Check.has_option types with - | true -> add_unit types - | false -> types + ] in + let types = match main with + | Some { pld_name = { txt = name ; _ }; pld_type ; _ } + -> types @ [ Labelled name, pld_type ] + | None when Check.has_option types -> add_unit types + | None -> types in let t = Construct.lambda_sig ~loc types record in let fun_name = "make_" ^ ty_name in From 4821f8c87ab556739e668ed508a7b39e91381fc0 Mon Sep 17 00:00:00 2001 From: aya Date: Fri, 4 Feb 2022 15:04:49 -0500 Subject: [PATCH 28/49] Add option and main tests for signature --- test/make/signature.t | 49 ++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 48 insertions(+), 1 deletion(-) diff --git a/test/make/signature.t b/test/make/signature.t index 6fad62f..56ea6b4 100644 --- a/test/make/signature.t +++ b/test/make/signature.t @@ -111,7 +111,7 @@ types, throw error [1] Test 8: Given a record type k with an `option` -field, expose make_k +field, expose make_k with a unit at the end $ test8=" > type k = { > x: int ; @@ -124,3 +124,50 @@ field, expose make_k include sig [@@@ocaml.warning "-32"] val make_k : x:int -> ?y:bool -> unit -> k end [@@ocaml.doc "@inline"][@@merlin.hide ] + +Test 9: Given a record type l annotated with `@main` for +one field, expose make_l with the main field at the end + $ test9=" + > type l = { + > x: int [@main] ; + > y: bool }[@@deriving make]" + $ echo "$test9" > test.mli + $ driver test.mli + type l = { + x: int [@main ]; + y: bool }[@@deriving make] + include sig [@@@ocaml.warning "-32"] val make_l : y:bool -> x:int -> l end + [@@ocaml.doc "@inline"][@@merlin.hide ] + +Test 10: Given a record type m annotated with `@main` for +more than 1 field, throw error requesting 1 main field + $ test10=" + > type m = { + > x: int ; + > y: bool [@main] ; + > z : string [@main]}[@@deriving make]" + $ echo "$test10" > test.mli + $ driver test.mli + File "test.mli", line 4, characters 2-19: + 4 | y: bool [@main] ; + ^^^^^^^^^^^^^^^^^ + Error: Duplicate [@deriving.make.main] annotation + [1] + +Test 11: Given a record type n annotated with 1 option field +and 1 @main field, expose make_n with the main field at the +end, and without a unit in the signature + $ test11=" + > type n = { + > x: int ; + > y: bool [@main] ; + > z : string option}[@@deriving make]" + $ echo "$test11" > test.mli + $ driver test.mli + type n = { + x: int ; + y: bool [@main ]; + z: string option }[@@deriving make] + include + sig [@@@ocaml.warning "-32"] val make_n : x:int -> ?z:string -> y:bool -> n + end[@@ocaml.doc "@inline"][@@merlin.hide ] From 5723fbb825aa17db9410670df9769ec2df613a0b Mon Sep 17 00:00:00 2001 From: aya Date: Tue, 8 Feb 2022 09:13:58 -0500 Subject: [PATCH 29/49] Implement main annotation for structure --- src/make/ppx_make.ml | 35 +++++++++++++++++++---------------- 1 file changed, 19 insertions(+), 16 deletions(-) diff --git a/src/make/ppx_make.ml b/src/make/ppx_make.ml index 6ea61d7..a6c5b95 100644 --- a/src/make/ppx_make.ml +++ b/src/make/ppx_make.ml @@ -40,7 +40,7 @@ end module Check = struct - let derivable ~loc rec_flag tds = + let is_derivable ~loc rec_flag tds = (match rec_flag with | Nonrecursive -> Location.raise_errorf ~loc "nonrec is not compatible with the `make' preprocessor." @@ -64,15 +64,8 @@ let has_option labels = List.exists (fun (name, _) -> match name with | Optional _ -> true | _ -> false) labels - end - - module Gen_sig = struct - let label_arg name ty = match ty with - (* a' option -> ?name , a' *) - | [%type: [%t? a'] option] -> Optional name, a' - | _ -> Labelled name, ty - let find_main labels = + let find_main labels = List.fold_right (fun ({ pld_type; pld_loc; pld_attributes ; _ } as label) (main, labels) -> if Ppx_deriving.(pld_type.ptyp_attributes @ pld_attributes |> attr ~deriver:"make" "main" |> Arg.get_flag ~deriver:"make") then @@ -82,10 +75,17 @@ else main, label :: labels) labels (None, []) + end + + module Gen_sig = struct + let label_arg name ty = match ty with + (* a' option -> ?name , a' *) + | [%type: [%t? a'] option] -> Optional name, a' + | _ -> Labelled name, ty let create_make_sig ~loc ~ty_name ~tps label_decls = let record = Construct.apply_type ~loc ~ty_name ~tps in - let main, label_decls = find_main label_decls in + let main_arg, label_decls = Check.find_main label_decls in let derive_type label_decl = let { pld_name = name; pld_type = ty; _ } = label_decl in label_arg name.txt ty @@ -95,7 +95,7 @@ Nolabel, Ast_helper.Typ.constr ~loc { txt = Lident "unit"; loc } [] ] in - let types = match main with + let types = match main_arg with | Some { pld_name = { txt = name ; _ }; pld_type ; _ } -> types @ [ Labelled name, pld_type ] | None when Check.has_option types -> add_unit types @@ -131,7 +131,7 @@ ;; let generate ~loc ~path:_ (rec_flag, tds) = - Check.derivable ~loc rec_flag tds; + Check.is_derivable ~loc rec_flag tds; List.concat_map (derive_per_td) tds ;; end @@ -144,13 +144,16 @@ ;; let create_make_fun ~loc ~record_name label_decls = + let main_arg, label_decls = Check.find_main label_decls in let names_and_types = List.map (fun label_decl -> label_decl.pld_name.txt, label_decl.pld_type) label_decls in let create_record = Construct.record ~loc (List.map (fun (n, _) -> n, evar ~loc n) names_and_types) in let patterns = List.map (fun (n,t) -> label_arg ~loc n t) names_and_types in let add_unit patterns = patterns @ [ Nolabel, punit ~loc ] in - let patterns = match Check.has_option patterns with - | true -> add_unit patterns - | false -> patterns + let patterns = match main_arg with + | Some { pld_name = { txt = name ; _ } ; _ } + -> patterns @ [ Labelled name, pvar ~loc name ] + | None when Check.has_option patterns -> add_unit patterns + | None -> patterns in let derive_lambda = Construct.lambda ~loc patterns create_record in let fun_name = "make_" ^ record_name in @@ -176,7 +179,7 @@ ;; let generate ~loc ~path:_ (rec_flag, tds) = - Check.derivable ~loc rec_flag tds; + Check.is_derivable ~loc rec_flag tds; List.concat_map (derive_per_td) tds ;; end From 7e698e56fc22c2d0c44f6e38d449164471d2da9b Mon Sep 17 00:00:00 2001 From: aya Date: Tue, 8 Feb 2022 09:14:20 -0500 Subject: [PATCH 30/49] Add main annotation tests --- test/make/signature.t | 22 ++++++++++++- test/make/structure.t | 75 +++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 96 insertions(+), 1 deletion(-) diff --git a/test/make/signature.t b/test/make/signature.t index 56ea6b4..82ca5da 100644 --- a/test/make/signature.t +++ b/test/make/signature.t @@ -140,7 +140,7 @@ one field, expose make_l with the main field at the end [@@ocaml.doc "@inline"][@@merlin.hide ] Test 10: Given a record type m annotated with `@main` for -more than 1 field, throw error requesting 1 main field +more than 1 field, throw error $ test10=" > type m = { > x: int ; @@ -171,3 +171,23 @@ end, and without a unit in the signature include sig [@@@ocaml.warning "-32"] val make_n : x:int -> ?z:string -> y:bool -> n end[@@ocaml.doc "@inline"][@@merlin.hide ] + +Test 11: Given a record type n annotated with 1 option field +and 1 @main field, expose make_n with the main field at the +end, and without a unit in the signature + $ test12=" + > type n = { + > x: int ; + > y: bool option [@main] ; + > z : string option}[@@deriving make]" + $ echo "$test12" > test.mli + $ driver test.mli + type n = { + x: int ; + y: bool option [@main ]; + z: string option }[@@deriving make] + include + sig + [@@@ocaml.warning "-32"] + val make_n : x:int -> ?z:string -> y:bool option -> n + end[@@ocaml.doc "@inline"][@@merlin.hide ] diff --git a/test/make/structure.t b/test/make/structure.t index a046474..217c580 100644 --- a/test/make/structure.t +++ b/test/make/structure.t @@ -139,3 +139,78 @@ field, derive make_k let make_k ~x ?y () = { x; y } let _ = make_k end[@@ocaml.doc "@inline"][@@merlin.hide ] + +Test 9: Given a record type l annotated with `@main` for +one field, expose make_l with the main field at the end + $ test9=" + > type l = { + > x: int [@main] ; + > y: bool }[@@deriving make]" + $ echo "$test9" > test.ml + $ driver test.ml + type l = { + x: int [@main ]; + y: bool }[@@deriving make] + include + struct + let _ = fun (_ : l) -> () + let make_l ~y ~x = { y } + let _ = make_l + end[@@ocaml.doc "@inline"][@@merlin.hide ] + +Test 10: Given a record type m annotated with `@main` for +more than 1 field, throw error + $ test10=" + > type m = { + > x: int ; + > y: bool [@main] ; + > z : string [@main]}[@@deriving make]" + $ echo "$test10" > test.ml + $ driver test.ml + File "test.ml", line 4, characters 2-19: + 4 | y: bool [@main] ; + ^^^^^^^^^^^^^^^^^ + Error: Duplicate [@deriving.make.main] annotation + [1] + +Test 11: Given a record type n annotated with 1 option field +and 1 @main field, expose make_n with the main field at the +end, and without a unit in the signature + $ test11=" + > type n = { + > x: int ; + > y: bool [@main] ; + > z : string option}[@@deriving make]" + $ echo "$test11" > test.ml + $ driver test.ml + type n = { + x: int ; + y: bool [@main ]; + z: string option }[@@deriving make] + include + struct + let _ = fun (_ : n) -> () + let make_n ~x ?z ~y = { x; z } + let _ = make_n + end[@@ocaml.doc "@inline"][@@merlin.hide ] + +Test 11: Given a record type n annotated with 1 option field +and 1 @main field, expose make_n with the main field at the +end, and without a unit in the signature + $ test12=" + > type n = { + > x: int ; + > y: bool option [@main] ; + > z : string option}[@@deriving make]" + $ echo "$test12" > test.ml + $ driver test.ml + type n = { + x: int ; + y: bool option [@main ]; + z: string option }[@@deriving make] + include + struct + let _ = fun (_ : n) -> () + let make_n ~x ?z ~y = { x; z } + let _ = make_n + end[@@ocaml.doc "@inline"][@@merlin.hide ] From de805c7f589f19e7b72b4e31308ec9e304a47233 Mon Sep 17 00:00:00 2001 From: aya Date: Wed, 9 Feb 2022 23:57:45 -0500 Subject: [PATCH 31/49] Remove labels for main fields and use fold_left --- src/make/ppx_make.ml | 48 ++++++++++++++++++++++++-------------------- 1 file changed, 26 insertions(+), 22 deletions(-) diff --git a/src/make/ppx_make.ml b/src/make/ppx_make.ml index a6c5b95..dd712c2 100644 --- a/src/make/ppx_make.ml +++ b/src/make/ppx_make.ml @@ -14,13 +14,13 @@ ;; let lambda ~loc patterns body = - List.fold_right (fun (lab, pat) acc -> - pexp_fun ~loc lab None pat acc) patterns body + List.fold_left (fun acc (lab, pat) -> + pexp_fun ~loc lab None pat acc) body patterns ;; let lambda_sig ~loc arg_tys body_ty = - List.fold_right (fun (lab, arg_ty) acc -> - ptyp_arrow ~loc lab arg_ty acc) arg_tys body_ty + List.fold_left (fun acc (lab, arg_ty) -> + ptyp_arrow ~loc lab arg_ty acc) body_ty arg_tys ;; let record ~loc pairs = @@ -61,12 +61,17 @@ type definition is a record.") ;; + let is_public ~private_ ~loc = + (match private_ with + | Private -> Location.raise_errorf ~loc "We cannot expose functions that explicitly create private records." + | Public -> () ) + let has_option labels = List.exists (fun (name, _) -> match name with | Optional _ -> true | _ -> false) labels let find_main labels = - List.fold_right (fun ({ pld_type; pld_loc; pld_attributes ; _ } as label) (main, labels) -> + List.fold_left (fun (main, labels) ({ pld_type; pld_loc; pld_attributes ; _ } as label) -> if Ppx_deriving.(pld_type.ptyp_attributes @ pld_attributes |> attr ~deriver:"make" "main" |> Arg.get_flag ~deriver:"make") then match main with @@ -74,7 +79,7 @@ | None -> Some label, labels else main, label :: labels) - labels (None, []) + (None, []) labels end module Gen_sig = struct @@ -91,13 +96,13 @@ label_arg name.txt ty in let types = List.map derive_type label_decls in - let add_unit types = types @ [ + let add_unit types = ( Nolabel, - Ast_helper.Typ.constr ~loc { txt = Lident "unit"; loc } [] - ] in + Ast_helper.Typ.constr ~loc { txt = Lident "unit"; loc } [] + )::types in let types = match main_arg with - | Some { pld_name = { txt = name ; _ }; pld_type ; _ } - -> types @ [ Labelled name, pld_type ] + | Some { pld_type ; _ } + -> (Nolabel, pld_type)::types | None when Check.has_option types -> add_unit types | None -> types in @@ -105,11 +110,6 @@ let fun_name = "make_" ^ ty_name in Construct.sig_item ~loc fun_name t ;; - - let check_public ~private_ ~loc = - (match private_ with - | Private -> Location.raise_errorf ~loc "We cannot expose functions that explicitly create private records." - | Public -> () ) let derive_per_td (td : type_declaration) : signature = let { ptype_name = { txt = ty_name; loc } @@ -124,7 +124,7 @@ let tps = List.map (fun (tp, _variance) -> tp) ptype_params in match ptype_kind with | Ptype_record label_decls -> - check_public ~private_ ~loc ; + Check.is_public ~private_ ~loc ; let derived_item = create_make_sig ~loc ~ty_name ~tps label_decls in [ derived_item ] | _ -> [] @@ -144,17 +144,21 @@ ;; let create_make_fun ~loc ~record_name label_decls = + let names = List.map (fun { pld_name = n; _ } -> n.txt, evar ~loc n.txt) label_decls in let main_arg, label_decls = Check.find_main label_decls in - let names_and_types = List.map (fun label_decl -> label_decl.pld_name.txt, label_decl.pld_type) label_decls in - let create_record = Construct.record ~loc (List.map (fun (n, _) -> n, evar ~loc n) names_and_types) in - let patterns = List.map (fun (n,t) -> label_arg ~loc n t) names_and_types in - let add_unit patterns = patterns @ [ Nolabel, punit ~loc ] in + let derive_pattern label_decl = + let { pld_name = name; pld_type = ty; _ } = label_decl in + label_arg ~loc name.txt ty + in + let patterns = List.map derive_pattern label_decls in + let add_unit patterns = (Nolabel, punit ~loc)::patterns in let patterns = match main_arg with | Some { pld_name = { txt = name ; _ } ; _ } - -> patterns @ [ Labelled name, pvar ~loc name ] + -> (Nolabel, pvar ~loc name)::patterns | None when Check.has_option patterns -> add_unit patterns | None -> patterns in + let create_record = Construct.record ~loc names in let derive_lambda = Construct.lambda ~loc patterns create_record in let fun_name = "make_" ^ record_name in Construct.str_item ~loc fun_name derive_lambda From 538fee7cf5dc7c07d5dc4d1828216e781aad73c1 Mon Sep 17 00:00:00 2001 From: aya Date: Wed, 9 Feb 2022 23:58:00 -0500 Subject: [PATCH 32/49] Update tests --- test/make/signature.t | 14 +++++++------- test/make/structure.t | 12 ++++++------ 2 files changed, 13 insertions(+), 13 deletions(-) diff --git a/test/make/signature.t b/test/make/signature.t index 82ca5da..a0de559 100644 --- a/test/make/signature.t +++ b/test/make/signature.t @@ -136,21 +136,21 @@ one field, expose make_l with the main field at the end type l = { x: int [@main ]; y: bool }[@@deriving make] - include sig [@@@ocaml.warning "-32"] val make_l : y:bool -> x:int -> l end + include sig [@@@ocaml.warning "-32"] val make_l : y:bool -> int -> l end [@@ocaml.doc "@inline"][@@merlin.hide ] Test 10: Given a record type m annotated with `@main` for more than 1 field, throw error $ test10=" > type m = { - > x: int ; + > x: int; > y: bool [@main] ; > z : string [@main]}[@@deriving make]" $ echo "$test10" > test.mli $ driver test.mli - File "test.mli", line 4, characters 2-19: - 4 | y: bool [@main] ; - ^^^^^^^^^^^^^^^^^ + File "test.mli", line 5, characters 2-20: + 5 | z : string [@main]}[@@deriving make] + ^^^^^^^^^^^^^^^^^^ Error: Duplicate [@deriving.make.main] annotation [1] @@ -169,7 +169,7 @@ end, and without a unit in the signature y: bool [@main ]; z: string option }[@@deriving make] include - sig [@@@ocaml.warning "-32"] val make_n : x:int -> ?z:string -> y:bool -> n + sig [@@@ocaml.warning "-32"] val make_n : x:int -> ?z:string -> bool -> n end[@@ocaml.doc "@inline"][@@merlin.hide ] Test 11: Given a record type n annotated with 1 option field @@ -189,5 +189,5 @@ end, and without a unit in the signature include sig [@@@ocaml.warning "-32"] - val make_n : x:int -> ?z:string -> y:bool option -> n + val make_n : x:int -> ?z:string -> bool option -> n end[@@ocaml.doc "@inline"][@@merlin.hide ] diff --git a/test/make/structure.t b/test/make/structure.t index 217c580..66dc667 100644 --- a/test/make/structure.t +++ b/test/make/structure.t @@ -154,7 +154,7 @@ one field, expose make_l with the main field at the end include struct let _ = fun (_ : l) -> () - let make_l ~y ~x = { y } + let make_l ~y x = { x; y } let _ = make_l end[@@ocaml.doc "@inline"][@@merlin.hide ] @@ -167,9 +167,9 @@ more than 1 field, throw error > z : string [@main]}[@@deriving make]" $ echo "$test10" > test.ml $ driver test.ml - File "test.ml", line 4, characters 2-19: - 4 | y: bool [@main] ; - ^^^^^^^^^^^^^^^^^ + File "test.ml", line 5, characters 2-20: + 5 | z : string [@main]}[@@deriving make] + ^^^^^^^^^^^^^^^^^^ Error: Duplicate [@deriving.make.main] annotation [1] @@ -190,7 +190,7 @@ end, and without a unit in the signature include struct let _ = fun (_ : n) -> () - let make_n ~x ?z ~y = { x; z } + let make_n ~x ?z y = { x; y; z } let _ = make_n end[@@ocaml.doc "@inline"][@@merlin.hide ] @@ -211,6 +211,6 @@ end, and without a unit in the signature include struct let _ = fun (_ : n) -> () - let make_n ~x ?z ~y = { x; z } + let make_n ~x ?z y = { x; y; z } let _ = make_n end[@@ocaml.doc "@inline"][@@merlin.hide ] From aa7af5ba520ce1b19bbe01a15d734e66f2984f94 Mon Sep 17 00:00:00 2001 From: aya Date: Thu, 10 Feb 2022 13:48:28 -0500 Subject: [PATCH 33/49] Update attributes to use ppxlib instead of ppx_deriving --- src/make/dune | 2 +- src/make/ppx_make.ml | 112 +++++++++++++++++++++++++------------------ 2 files changed, 66 insertions(+), 48 deletions(-) diff --git a/src/make/dune b/src/make/dune index 7176be2..5f96808 100644 --- a/src/make/dune +++ b/src/make/dune @@ -1,3 +1,3 @@ (library (name ppx_make) - (kind ppx_deriver) (ppx_runtime_libraries fieldslib) (libraries ppxlib ppx_deriving.api) + (kind ppx_deriver) (ppx_runtime_libraries fieldslib) (libraries ppxlib) (preprocess (pps ppxlib.metaquot))) diff --git a/src/make/ppx_make.ml b/src/make/ppx_make.ml index dd712c2..315f727 100644 --- a/src/make/ppx_make.ml +++ b/src/make/ppx_make.ml @@ -6,37 +6,23 @@ open Ppxlib open Ast_builder.Default - module Construct = struct - (* Additional AST construction helpers *) - - let apply_type ~loc ~ty_name ~tps = - ptyp_constr ~loc (Located.lident ~loc ty_name) tps - ;; - - let lambda ~loc patterns body = - List.fold_left (fun acc (lab, pat) -> - pexp_fun ~loc lab None pat acc) body patterns - ;; - - let lambda_sig ~loc arg_tys body_ty = - List.fold_left (fun acc (lab, arg_ty) -> - ptyp_arrow ~loc lab arg_ty acc) body_ty arg_tys - ;; - - let record ~loc pairs = - pexp_record - ~loc - (List.map (fun (name, exp) -> Located.lident ~loc name, exp) pairs) - None - ;; + module Annotations = struct + let main_attr = + Attribute.declare + "standard_derivers.make.main" + Attribute.Context.label_declaration + Ast_pattern.(pstr nil) + () + ;; - let sig_item ~loc name typ = - psig_value ~loc (value_description ~loc ~name:(Located.mk ~loc name) ~type_:typ ~prim:[]) + let find_main labels = + List.fold_left (fun (main_label, labels) ({ pld_loc; _ } as label) -> + match Attribute.get main_attr label, main_label with + | Some _, Some _ -> Location.raise_errorf ~loc:pld_loc "Duplicate [@deriving.%s.main] annotation" "make" + | Some _, None -> Some label, labels + | None, _ -> main_label, label :: labels) + (None, []) labels ;; - - let str_item ~loc name body = - pstr_value ~loc Nonrecursive [ value_binding ~loc ~pat:(pvar ~loc name) ~expr:body ] - ;; end module Check = struct @@ -65,32 +51,57 @@ (match private_ with | Private -> Location.raise_errorf ~loc "We cannot expose functions that explicitly create private records." | Public -> () ) + ;; let has_option labels = List.exists (fun (name, _) -> match name with | Optional _ -> true | _ -> false) labels - - let find_main labels = - List.fold_left (fun (main, labels) ({ pld_type; pld_loc; pld_attributes ; _ } as label) -> - if Ppx_deriving.(pld_type.ptyp_attributes @ pld_attributes |> - attr ~deriver:"make" "main" |> Arg.get_flag ~deriver:"make") then - match main with - | Some _ -> Location.raise_errorf ~loc:pld_loc "Duplicate [@deriving.%s.main] annotation" "make" - | None -> Some label, labels - else - main, label :: labels) - (None, []) labels + ;; end + + module Construct = struct + (* Additional AST construction helpers *) + + let apply_type ~loc ~ty_name ~tps = + ptyp_constr ~loc (Located.lident ~loc ty_name) tps + ;; + + let lambda ~loc patterns body = + List.fold_left (fun acc (lab, pat) -> + pexp_fun ~loc lab None pat acc) body patterns + ;; + + let lambda_sig ~loc arg_tys body_ty = + List.fold_left (fun acc (lab, arg_ty) -> + ptyp_arrow ~loc lab arg_ty acc) body_ty arg_tys + ;; + + let record ~loc pairs = + pexp_record + ~loc + (List.map (fun (name, exp) -> Located.lident ~loc name, exp) pairs) + None + ;; + + let sig_item ~loc name typ = + psig_value ~loc (value_description ~loc ~name:(Located.mk ~loc name) ~type_:typ ~prim:[]) + ;; + + let str_item ~loc name body = + pstr_value ~loc Nonrecursive [ value_binding ~loc ~pat:(pvar ~loc name) ~expr:body ] + ;; + end module Gen_sig = struct let label_arg name ty = match ty with (* a' option -> ?name , a' *) | [%type: [%t? a'] option] -> Optional name, a' | _ -> Labelled name, ty - + ;; + let create_make_sig ~loc ~ty_name ~tps label_decls = let record = Construct.apply_type ~loc ~ty_name ~tps in - let main_arg, label_decls = Check.find_main label_decls in + let main_arg, label_decls = Annotations.find_main label_decls in let derive_type label_decl = let { pld_name = name; pld_type = ty; _ } = label_decl in label_arg name.txt ty @@ -144,8 +155,8 @@ ;; let create_make_fun ~loc ~record_name label_decls = - let names = List.map (fun { pld_name = n; _ } -> n.txt, evar ~loc n.txt) label_decls in - let main_arg, label_decls = Check.find_main label_decls in + let field_labels = List.map (fun { pld_name = n; _ } -> n.txt, evar ~loc n.txt) label_decls in + let main_arg, label_decls = Annotations.find_main label_decls in let derive_pattern label_decl = let { pld_name = name; pld_type = ty; _ } = label_decl in label_arg ~loc name.txt ty @@ -158,7 +169,7 @@ | None when Check.has_option patterns -> add_unit patterns | None -> patterns in - let create_record = Construct.record ~loc names in + let create_record = Construct.record ~loc field_labels in let derive_lambda = Construct.lambda ~loc patterns create_record in let fun_name = "make_" ^ record_name in Construct.str_item ~loc fun_name derive_lambda @@ -189,9 +200,16 @@ end let make = + let attributes = [ + Attribute.T Annotations.main_attr + ] in Deriving.add "make" ~str_type_decl: - (Deriving.Generator.make_noarg Gen_struct.generate) + (Deriving.Generator.make_noarg + ~attributes + Gen_struct.generate) ~sig_type_decl: - (Deriving.Generator.make_noarg Gen_sig.generate) + (Deriving.Generator.make_noarg + ~attributes + Gen_sig.generate) ;; From b6423538c1bff1b67b6748c87e05beebde59786b Mon Sep 17 00:00:00 2001 From: aya Date: Thu, 10 Feb 2022 16:39:03 -0500 Subject: [PATCH 34/49] Update tests --- test/make/optionals.t | 164 ++++++++++++++++++++++++++++++++++++++++++ test/make/signature.t | 82 --------------------- test/make/structure.t | 137 +++++------------------------------ 3 files changed, 182 insertions(+), 201 deletions(-) create mode 100644 test/make/optionals.t diff --git a/test/make/optionals.t b/test/make/optionals.t new file mode 100644 index 0000000..988ccf7 --- /dev/null +++ b/test/make/optionals.t @@ -0,0 +1,164 @@ +--------------------------------------------------- +NOTICE: @@ocaml.doc and @@merlin.hide annotations +& `include struct` boilerplate are added by ppxlib. +--------------------------------------------------- + +Test 1: Given a record type a with an `option` field, +make_a will accept an optional param and have a unit +at the end of its signature + $ test1=" + > type a = { + > x: int ; + > y: bool option }[@@deriving make]" + $ echo "$test1" > test.ml + $ driver test.ml + type k = { + x: int ; + y: bool option }[@@deriving make] + include + struct + let _ = fun (_ : k) -> () + let make_k ~x ?y () = { x; y } + let _ = make_k + end[@@ocaml.doc "@inline"][@@merlin.hide ] + $ echo "$test1" > test.mli + $ driver test.mli + type k = { + x: int ; + y: bool option }[@@deriving make] + include + sig [@@@ocaml.warning "-32"] val make_k : x:int -> ?y:bool -> unit -> k end + [@@ocaml.doc "@inline"][@@merlin.hide ] + +Test 2: Given a record type b annotated with `@main` for +one field, make_b will accept the main field as its last +parameter + $ test2=" + > type b = { + > x: int [@main] ; + > y: bool }[@@deriving make]" + $ echo "$test2" > test.ml + $ driver test.ml + type l = { + x: int [@main ]; + y: bool }[@@deriving make] + include + struct + let _ = fun (_ : l) -> () + let make_l ~y x = { x; y } + let _ = make_l + end[@@ocaml.doc "@inline"][@@merlin.hide ] + $ echo "$test2" > test.mli + $ driver test.mli + type l = { + x: int [@main ]; + y: bool }[@@deriving make] + include sig [@@@ocaml.warning "-32"] val make_l : y:bool -> int -> l end + [@@ocaml.doc "@inline"][@@merlin.hide ] + +Test 3: Given a record type c annotated with `@main` for +more than 1 field, throw error + $ test3=" + > type c = { + > x: int ; + > y: bool [@main] ; + > z : string [@main]}[@@deriving make]" + $ echo "$test3" > test.ml + $ driver test.ml + File "test.ml", line 5, characters 2-20: + 5 | z : string [@main]}[@@deriving make] + ^^^^^^^^^^^^^^^^^^ + Error: Duplicate [@deriving.make.main] annotation + [1] + $ echo "$test3" > test.mli + $ driver test.mli + File "test.mli", line 5, characters 2-20: + 5 | z : string [@main]}[@@deriving make] + ^^^^^^^^^^^^^^^^^^ + Error: Duplicate [@deriving.make.main] annotation + [1] + +Test 4: Given a record type d with an option field & a +@main field, make_d accepts the main field as the last +parameter, and does not have a unit in the signature + $ test4=" + > type d = { + > x: int ; + > y: bool [@main] ; + > z : string option}[@@deriving make]" + $ echo "$test4" > test.ml + $ driver test.ml + type n = { + x: int ; + y: bool [@main ]; + z: string option }[@@deriving make] + include + struct + let _ = fun (_ : n) -> () + let make_n ~x ?z y = { x; y; z } + let _ = make_n + end[@@ocaml.doc "@inline"][@@merlin.hide ] + $ echo "$test4" > test.mli + $ driver test.mli + type n = { + x: int ; + y: bool [@main ]; + z: string option }[@@deriving make] + include + sig [@@@ocaml.warning "-32"] val make_n : x:int -> ?z:string -> bool -> n + end[@@ocaml.doc "@inline"][@@merlin.hide ] + +Test 5: Given record type e with 2 option fields, one +of which is also annotated with @main, make_e accepts +the main field as the last param, which is of type +`option` but is not optional + $ test5=" + > type e = { + > x: int ; + > y: bool option [@main] ; + > z : string option}[@@deriving make]" + $ echo "$test5" > test.ml + $ driver -deriving-keep-w32 both test.ml + type n = { + x: int ; + y: bool option [@main ]; + z: string option }[@@deriving make] + include struct let make_n ~x ?z y = { x; y; z } end[@@ocaml.doc "@inline"] + [@@merlin.hide ] + $ echo "$test5" > test.mli + $ driver test.mli + type n = { + x: int ; + y: bool option [@main ]; + z: string option }[@@deriving make] + include + sig + [@@@ocaml.warning "-32"] + val make_n : x:int -> ?z:string -> bool option -> n + end[@@ocaml.doc "@inline"][@@merlin.hide ] + +Test 6: Testing ppxlib: Unexpected attribute payload + $ test6=" + > type l = { + > x: int [@main 5] ; + > y: bool }[@@deriving make]" + $ echo "$test6" > test.mli + $ driver test.mli + File "test.mli", line 3, characters 16-17: + 3 | x: int [@main 5] ; + ^ + Error: [] expected + [1] + +Test 7: Testing ppxlib: Unrecognized annotation + $ test7=" + > type l = { + > x: int [@mein 5] ; + > y: bool }[@@deriving make]" + $ echo "$test7" > test.mli + $ driver -check test.mli + File "test.mli", line 3, characters 11-15: + 3 | x: int [@mein 5] ; + ^^^^ + Error: Attribute `mein' was not used + [1] diff --git a/test/make/signature.t b/test/make/signature.t index a0de559..9070c59 100644 --- a/test/make/signature.t +++ b/test/make/signature.t @@ -109,85 +109,3 @@ types, throw error 3 | and j = bool*i [@@deriving make] Error: make can only be applied on type definitions in which at least one type definition is a record. [1] - -Test 8: Given a record type k with an `option` -field, expose make_k with a unit at the end - $ test8=" - > type k = { - > x: int ; - > y: bool option }[@@deriving make]" - $ echo "$test8" > test.mli - $ driver test.mli - type k = { - x: int ; - y: bool option }[@@deriving make] - include - sig [@@@ocaml.warning "-32"] val make_k : x:int -> ?y:bool -> unit -> k end - [@@ocaml.doc "@inline"][@@merlin.hide ] - -Test 9: Given a record type l annotated with `@main` for -one field, expose make_l with the main field at the end - $ test9=" - > type l = { - > x: int [@main] ; - > y: bool }[@@deriving make]" - $ echo "$test9" > test.mli - $ driver test.mli - type l = { - x: int [@main ]; - y: bool }[@@deriving make] - include sig [@@@ocaml.warning "-32"] val make_l : y:bool -> int -> l end - [@@ocaml.doc "@inline"][@@merlin.hide ] - -Test 10: Given a record type m annotated with `@main` for -more than 1 field, throw error - $ test10=" - > type m = { - > x: int; - > y: bool [@main] ; - > z : string [@main]}[@@deriving make]" - $ echo "$test10" > test.mli - $ driver test.mli - File "test.mli", line 5, characters 2-20: - 5 | z : string [@main]}[@@deriving make] - ^^^^^^^^^^^^^^^^^^ - Error: Duplicate [@deriving.make.main] annotation - [1] - -Test 11: Given a record type n annotated with 1 option field -and 1 @main field, expose make_n with the main field at the -end, and without a unit in the signature - $ test11=" - > type n = { - > x: int ; - > y: bool [@main] ; - > z : string option}[@@deriving make]" - $ echo "$test11" > test.mli - $ driver test.mli - type n = { - x: int ; - y: bool [@main ]; - z: string option }[@@deriving make] - include - sig [@@@ocaml.warning "-32"] val make_n : x:int -> ?z:string -> bool -> n - end[@@ocaml.doc "@inline"][@@merlin.hide ] - -Test 11: Given a record type n annotated with 1 option field -and 1 @main field, expose make_n with the main field at the -end, and without a unit in the signature - $ test12=" - > type n = { - > x: int ; - > y: bool option [@main] ; - > z : string option}[@@deriving make]" - $ echo "$test12" > test.mli - $ driver test.mli - type n = { - x: int ; - y: bool option [@main ]; - z: string option }[@@deriving make] - include - sig - [@@@ocaml.warning "-32"] - val make_n : x:int -> ?z:string -> bool option -> n - end[@@ocaml.doc "@inline"][@@merlin.hide ] diff --git a/test/make/structure.t b/test/make/structure.t index 66dc667..a87aae5 100644 --- a/test/make/structure.t +++ b/test/make/structure.t @@ -2,6 +2,12 @@ NOTICE: @@ocaml.doc and @@merlin.hide annotations & `include struct` boilerplate are added by ppxlib. --------------------------------------------------- +The `-deriving-keep-w32 both` flag added after the +driver removes anonymous functions of the type: +- let _ = fun (_ : t) -> () +- let _ = make_t +which are automatically added by ppxlib. +--------------------------------------------------- Test 1: Given a regular record type a, derive make_a $ test1=" @@ -9,16 +15,12 @@ Test 1: Given a regular record type a, derive make_a > x: int ; > y: bool }[@@deriving make]" $ echo "$test1" > test.ml - $ driver test.ml + $ driver -deriving-keep-w32 both test.ml type a = { x: int ; y: bool }[@@deriving make] - include - struct - let _ = fun (_ : a) -> () - let make_a ~x ~y = { x; y } - let _ = make_a - end[@@ocaml.doc "@inline"][@@merlin.hide ] + include struct let make_a ~x ~y = { x; y } end[@@ocaml.doc "@inline"] + [@@merlin.hide ] Test 2: Given a nonrec type, throw error $ test2=" @@ -26,7 +28,7 @@ Test 2: Given a nonrec type, throw error > x: int ; > y: bool }[@@deriving make]" $ echo "$test2" > test.ml - $ driver test.ml + $ driver -deriving-keep-w32 both test.ml File "test.ml", lines 2-4, characters 0-28: 2 | type nonrec b = { 3 | x: int ; @@ -39,7 +41,7 @@ Test 3: Given a non-record type, throw error > type c = int * int > [@@deriving make]" $ echo "$test3" > test.ml - $ driver test.ml + $ driver -deriving-keep-w32 both test.ml File "test.ml", lines 2-3, characters 0-17: 2 | type c = int * int 3 | [@@deriving make] @@ -52,12 +54,11 @@ Test 4: Given a private record type d, derive make_d > x: int ; > y: bool }[@@deriving make]" $ echo "$test4" > test.ml - $ driver test.ml + $ driver -deriving-keep-w32 both test.ml type d = private { x: int ; y: bool }[@@deriving make] - include struct let _ = fun (_ : d) -> () end[@@ocaml.doc "@inline"][@@merlin.hide - ] + include struct end[@@ocaml.doc "@inline"][@@merlin.hide ] Test 5: Given recursive types which are exclusively record types, derive 1 make function for each record @@ -70,7 +71,7 @@ record types, derive 1 make function for each record > mutable y: bool ; > z: e }[@@deriving make]" $ echo "$test5" > test.ml - $ driver test.ml + $ driver -deriving-keep-w32 both test.ml type e = { v: f ; w: bool } @@ -80,12 +81,8 @@ record types, derive 1 make function for each record z: e }[@@deriving make] include struct - let _ = fun (_ : e) -> () - let _ = fun (_ : f) -> () let make_e ~v ~w = { v; w } - let _ = make_e let make_f ~x ~y ~z = { x; y; z } - let _ = make_f end[@@ocaml.doc "@inline"][@@merlin.hide ] Test 6: Given recursive types with at least one @@ -96,18 +93,13 @@ record type, derive one make function for each type > v: g ; > w: bool }[@@deriving make]" $ echo "$test6" > test.ml - $ driver test.ml + $ driver -deriving-keep-w32 both test.ml type g = (int * h) and h = { v: g ; w: bool }[@@deriving make] - include - struct - let _ = fun (_ : g) -> () - let _ = fun (_ : h) -> () - let make_h ~v ~w = { v; w } - let _ = make_h - end[@@ocaml.doc "@inline"][@@merlin.hide ] + include struct let make_h ~v ~w = { v; w } end[@@ocaml.doc "@inline"] + [@@merlin.hide ] Test 7: Given recursive types without any record types, throw error @@ -115,102 +107,9 @@ types, throw error > type i = int*j > and i = bool*j [@@deriving make]" $ echo "$test7" > test.ml - $ driver test.ml + $ driver -deriving-keep-w32 both test.ml File "test.ml", lines 2-3, characters 0-32: 2 | type i = int*j 3 | and i = bool*j [@@deriving make] Error: make can only be applied on type definitions in which at least one type definition is a record. [1] - -Test 8: Given a record type k with an `option` -field, derive make_k - $ test8=" - > type k = { - > x: int ; - > y: bool option }[@@deriving make]" - $ echo "$test8" > test.ml - $ driver test.ml - type k = { - x: int ; - y: bool option }[@@deriving make] - include - struct - let _ = fun (_ : k) -> () - let make_k ~x ?y () = { x; y } - let _ = make_k - end[@@ocaml.doc "@inline"][@@merlin.hide ] - -Test 9: Given a record type l annotated with `@main` for -one field, expose make_l with the main field at the end - $ test9=" - > type l = { - > x: int [@main] ; - > y: bool }[@@deriving make]" - $ echo "$test9" > test.ml - $ driver test.ml - type l = { - x: int [@main ]; - y: bool }[@@deriving make] - include - struct - let _ = fun (_ : l) -> () - let make_l ~y x = { x; y } - let _ = make_l - end[@@ocaml.doc "@inline"][@@merlin.hide ] - -Test 10: Given a record type m annotated with `@main` for -more than 1 field, throw error - $ test10=" - > type m = { - > x: int ; - > y: bool [@main] ; - > z : string [@main]}[@@deriving make]" - $ echo "$test10" > test.ml - $ driver test.ml - File "test.ml", line 5, characters 2-20: - 5 | z : string [@main]}[@@deriving make] - ^^^^^^^^^^^^^^^^^^ - Error: Duplicate [@deriving.make.main] annotation - [1] - -Test 11: Given a record type n annotated with 1 option field -and 1 @main field, expose make_n with the main field at the -end, and without a unit in the signature - $ test11=" - > type n = { - > x: int ; - > y: bool [@main] ; - > z : string option}[@@deriving make]" - $ echo "$test11" > test.ml - $ driver test.ml - type n = { - x: int ; - y: bool [@main ]; - z: string option }[@@deriving make] - include - struct - let _ = fun (_ : n) -> () - let make_n ~x ?z y = { x; y; z } - let _ = make_n - end[@@ocaml.doc "@inline"][@@merlin.hide ] - -Test 11: Given a record type n annotated with 1 option field -and 1 @main field, expose make_n with the main field at the -end, and without a unit in the signature - $ test12=" - > type n = { - > x: int ; - > y: bool option [@main] ; - > z : string option}[@@deriving make]" - $ echo "$test12" > test.ml - $ driver test.ml - type n = { - x: int ; - y: bool option [@main ]; - z: string option }[@@deriving make] - include - struct - let _ = fun (_ : n) -> () - let make_n ~x ?z y = { x; y; z } - let _ = make_n - end[@@ocaml.doc "@inline"][@@merlin.hide ] From 33e46c32e49940929433c0336401bc692b3ee5a7 Mon Sep 17 00:00:00 2001 From: aya Date: Fri, 11 Feb 2022 10:23:17 -0500 Subject: [PATCH 35/49] Edit test names --- test/make/optionals.t | 44 +++++++++++++++++++++---------------------- 1 file changed, 22 insertions(+), 22 deletions(-) diff --git a/test/make/optionals.t b/test/make/optionals.t index 988ccf7..161489a 100644 --- a/test/make/optionals.t +++ b/test/make/optionals.t @@ -12,22 +12,22 @@ at the end of its signature > y: bool option }[@@deriving make]" $ echo "$test1" > test.ml $ driver test.ml - type k = { + type a = { x: int ; y: bool option }[@@deriving make] include struct - let _ = fun (_ : k) -> () - let make_k ~x ?y () = { x; y } - let _ = make_k + let _ = fun (_ : a) -> () + let make_a ~x ?y () = { x; y } + let _ = make_a end[@@ocaml.doc "@inline"][@@merlin.hide ] $ echo "$test1" > test.mli $ driver test.mli - type k = { + type a = { x: int ; y: bool option }[@@deriving make] include - sig [@@@ocaml.warning "-32"] val make_k : x:int -> ?y:bool -> unit -> k end + sig [@@@ocaml.warning "-32"] val make_a : x:int -> ?y:bool -> unit -> a end [@@ocaml.doc "@inline"][@@merlin.hide ] Test 2: Given a record type b annotated with `@main` for @@ -39,21 +39,21 @@ parameter > y: bool }[@@deriving make]" $ echo "$test2" > test.ml $ driver test.ml - type l = { + type b = { x: int [@main ]; y: bool }[@@deriving make] include struct - let _ = fun (_ : l) -> () - let make_l ~y x = { x; y } - let _ = make_l + let _ = fun (_ : b) -> () + let make_b ~y x = { x; y } + let _ = make_b end[@@ocaml.doc "@inline"][@@merlin.hide ] $ echo "$test2" > test.mli $ driver test.mli - type l = { + type b = { x: int [@main ]; y: bool }[@@deriving make] - include sig [@@@ocaml.warning "-32"] val make_l : y:bool -> int -> l end + include sig [@@@ocaml.warning "-32"] val make_b : y:bool -> int -> b end [@@ocaml.doc "@inline"][@@merlin.hide ] Test 3: Given a record type c annotated with `@main` for @@ -88,24 +88,24 @@ parameter, and does not have a unit in the signature > z : string option}[@@deriving make]" $ echo "$test4" > test.ml $ driver test.ml - type n = { + type d = { x: int ; y: bool [@main ]; z: string option }[@@deriving make] include struct - let _ = fun (_ : n) -> () - let make_n ~x ?z y = { x; y; z } - let _ = make_n + let _ = fun (_ : d) -> () + let make_d ~x ?z y = { x; y; z } + let _ = make_d end[@@ocaml.doc "@inline"][@@merlin.hide ] $ echo "$test4" > test.mli $ driver test.mli - type n = { + type d = { x: int ; y: bool [@main ]; z: string option }[@@deriving make] include - sig [@@@ocaml.warning "-32"] val make_n : x:int -> ?z:string -> bool -> n + sig [@@@ocaml.warning "-32"] val make_d : x:int -> ?z:string -> bool -> d end[@@ocaml.doc "@inline"][@@merlin.hide ] Test 5: Given record type e with 2 option fields, one @@ -119,22 +119,22 @@ the main field as the last param, which is of type > z : string option}[@@deriving make]" $ echo "$test5" > test.ml $ driver -deriving-keep-w32 both test.ml - type n = { + type e = { x: int ; y: bool option [@main ]; z: string option }[@@deriving make] - include struct let make_n ~x ?z y = { x; y; z } end[@@ocaml.doc "@inline"] + include struct let make_e ~x ?z y = { x; y; z } end[@@ocaml.doc "@inline"] [@@merlin.hide ] $ echo "$test5" > test.mli $ driver test.mli - type n = { + type e = { x: int ; y: bool option [@main ]; z: string option }[@@deriving make] include sig [@@@ocaml.warning "-32"] - val make_n : x:int -> ?z:string -> bool option -> n + val make_e : x:int -> ?z:string -> bool option -> e end[@@ocaml.doc "@inline"][@@merlin.hide ] Test 6: Testing ppxlib: Unexpected attribute payload From 6dfa525136a2e83639fca670cce5cfc456e96f5a Mon Sep 17 00:00:00 2001 From: aya Date: Tue, 15 Feb 2022 10:42:40 -0500 Subject: [PATCH 36/49] Add @default annotation --- src/make/ppx_make.ml | 53 ++++++++++++++++++++++++++------------------ 1 file changed, 31 insertions(+), 22 deletions(-) diff --git a/src/make/ppx_make.ml b/src/make/ppx_make.ml index 315f727..fd38a31 100644 --- a/src/make/ppx_make.ml +++ b/src/make/ppx_make.ml @@ -7,6 +7,14 @@ open Ast_builder.Default module Annotations = struct + let default_attr = + Attribute.declare + "standard_derivers.make.default" + Attribute.Context.label_declaration + Ast_pattern.(single_expr_payload __) + (fun expr -> expr) + ;; + let main_attr = Attribute.declare "standard_derivers.make.main" @@ -53,7 +61,7 @@ | Public -> () ) ;; - let has_option labels = List.exists (fun (name, _) -> match name with + let is_optional labels = List.exists (fun (name, _) -> match name with | Optional _ -> true | _ -> false) labels ;; @@ -93,19 +101,21 @@ end module Gen_sig = struct - let label_arg name ty = match ty with - (* a' option -> ?name , a' *) - | [%type: [%t? a'] option] -> Optional name, a' - | _ -> Labelled name, ty + let label_arg label_decl = + let { pld_name = name; pld_type = ty; _ } = label_decl in + match (Attribute.get Annotations.default_attr label_decl), ty with + (* @default -> Optional *) + | Some _, _ -> Optional name.txt, ty + (* option type -> Optional *) + | _, [%type: [%t? a'] option] -> Optional name.txt, a' + (* regular field -> Labelled *) + | _ -> Labelled name.txt, ty ;; let create_make_sig ~loc ~ty_name ~tps label_decls = let record = Construct.apply_type ~loc ~ty_name ~tps in let main_arg, label_decls = Annotations.find_main label_decls in - let derive_type label_decl = - let { pld_name = name; pld_type = ty; _ } = label_decl in - label_arg name.txt ty - in + let derive_type label_decl = label_arg label_decl in let types = List.map derive_type label_decls in let add_unit types = ( Nolabel, @@ -114,7 +124,7 @@ let types = match main_arg with | Some { pld_type ; _ } -> (Nolabel, pld_type)::types - | None when Check.has_option types -> add_unit types + | None when Check.is_optional types -> add_unit types | None -> types in let t = Construct.lambda_sig ~loc types record in @@ -148,25 +158,24 @@ end module Gen_struct = struct - let label_arg ~loc name ty = - match ty with - | [%type: [%t? _] option] -> Optional name, pvar ~loc name - | _ -> Labelled name, pvar ~loc name + let label_arg ~loc label_decl = + let{ pld_name = name; pld_type = ty; _ } = label_decl in + match (Attribute.get Annotations.default_attr label_decl), ty with + | Some _ , _ + | _, [%type: [%t? _] option] -> Optional name.txt, pvar ~loc name.txt + | _ -> Labelled name.txt, pvar ~loc name.txt ;; let create_make_fun ~loc ~record_name label_decls = let field_labels = List.map (fun { pld_name = n; _ } -> n.txt, evar ~loc n.txt) label_decls in let main_arg, label_decls = Annotations.find_main label_decls in - let derive_pattern label_decl = - let { pld_name = name; pld_type = ty; _ } = label_decl in - label_arg ~loc name.txt ty - in + let derive_pattern label_decl = label_arg ~loc label_decl in let patterns = List.map derive_pattern label_decls in let add_unit patterns = (Nolabel, punit ~loc)::patterns in let patterns = match main_arg with | Some { pld_name = { txt = name ; _ } ; _ } -> (Nolabel, pvar ~loc name)::patterns - | None when Check.has_option patterns -> add_unit patterns + | None when Check.is_optional patterns -> add_unit patterns | None -> patterns in let create_record = Construct.record ~loc field_labels in @@ -200,9 +209,9 @@ end let make = - let attributes = [ - Attribute.T Annotations.main_attr - ] in + let attributes = + (Attribute.T Annotations.default_attr)::[Attribute.T Annotations.main_attr] + in Deriving.add "make" ~str_type_decl: (Deriving.Generator.make_noarg From 8ce7e9128a6cbd98584a8af8a919a8ba0c8c0303 Mon Sep 17 00:00:00 2001 From: aya Date: Tue, 15 Feb 2022 10:42:56 -0500 Subject: [PATCH 37/49] Add @default tests --- test/make/annotations.t | 97 ++++++++++++++++++++++++ test/make/option.t | 89 ++++++++++++++++++++++ test/make/optionals.t | 164 ---------------------------------------- 3 files changed, 186 insertions(+), 164 deletions(-) create mode 100644 test/make/annotations.t create mode 100644 test/make/option.t delete mode 100644 test/make/optionals.t diff --git a/test/make/annotations.t b/test/make/annotations.t new file mode 100644 index 0000000..e0c1de7 --- /dev/null +++ b/test/make/annotations.t @@ -0,0 +1,97 @@ +--------------------------------------------------- +NOTICE: @@ocaml.doc and @@merlin.hide annotations +& `include struct` boilerplate are added by ppxlib. +--------------------------------------------------- + +Test 1: Given a record type a annotated with `@main` for +one field, make_a will accept the main field as its last +parameter + $ test1=" + > type a = { + > x: int [@main] ; + > y: bool }[@@deriving make]" + $ echo "$test1" > test.ml + $ driver -deriving-keep-w32 both test.ml + type a = { + x: int [@main ]; + y: bool }[@@deriving make] + include struct let make_a ~y x = { x; y } end[@@ocaml.doc "@inline"] + [@@merlin.hide ] + $ echo "$test1" > test.mli + $ driver test.mli + type a = { + x: int [@main ]; + y: bool }[@@deriving make] + include sig [@@@ocaml.warning "-32"] val make_a : y:bool -> int -> a end + [@@ocaml.doc "@inline"][@@merlin.hide ] + +Test 2: Given a record type b annotated with `@main` for +more than 1 field, throw error + $ test2=" + > type b = { + > x: int ; + > y: bool [@main] ; + > z : string [@main]}[@@deriving make]" + $ echo "$test2" > test.ml + $ driver -deriving-keep-w32 both test.ml + File "test.ml", line 5, characters 2-20: + 5 | z : string [@main]}[@@deriving make] + ^^^^^^^^^^^^^^^^^^ + Error: Duplicate [@deriving.make.main] annotation + [1] + $ echo "$test2" > test.mli + $ driver test.mli + File "test.mli", line 5, characters 2-20: + 5 | z : string [@main]}[@@deriving make] + ^^^^^^^^^^^^^^^^^^ + Error: Duplicate [@deriving.make.main] annotation + [1] + + +Test 3: @default makes the field optional + $ test3=" + > type c = { + > x: int [@default 5]; + > y: bool }[@@deriving make]" + $ echo "$test3" > test.mli + $ driver test.mli + type c = { + x: int [@default 5]; + y: bool }[@@deriving make] + include + sig [@@@ocaml.warning "-32"] val make_c : ?x:int -> y:bool -> unit -> c end + [@@ocaml.doc "@inline"][@@merlin.hide ] + $ echo "$test3" > test.ml + $ driver -deriving-keep-w32 both test.ml + type c = { + x: int [@default 5]; + y: bool }[@@deriving make] + include struct let make_c ?x ~y () = { x; y } end[@@ocaml.doc "@inline"] + [@@merlin.hide ] + + +Test 6: Testing ppxlib: Unexpected attribute payload + $ test6=" + > type l = { + > x: int [@main 5] ; + > y: bool }[@@deriving make]" + $ echo "$test6" > test.mli + $ driver test.mli + File "test.mli", line 3, characters 16-17: + 3 | x: int [@main 5] ; + ^ + Error: [] expected + [1] + +Test 7: Testing ppxlib: Unrecognized annotation + $ test7=" + > type l = { + > x: int [@mein 5] ; + > y: bool }[@@deriving make]" + $ echo "$test7" > test.mli + $ driver -check test.mli + File "test.mli", line 3, characters 11-15: + 3 | x: int [@mein 5] ; + ^^^^ + Error: Attribute `mein' was not used + [1] diff --git a/test/make/option.t b/test/make/option.t new file mode 100644 index 0000000..0229b9c --- /dev/null +++ b/test/make/option.t @@ -0,0 +1,89 @@ +--------------------------------------------------- +NOTICE: @@ocaml.doc and @@merlin.hide annotations +& `include struct` boilerplate are added by ppxlib. +--------------------------------------------------- +The `-deriving-keep-w32 both` flag added after the +driver removes anonymous functions of the type: +- let _ = fun (_ : t) -> () +- let _ = make_t +which are automatically added by ppxlib. +--------------------------------------------------- + +Test 1: Given a record type `a` with an `option` field, +make_a will accept an optional param and have a unit at +the end of its signature + $ test1=" + > type a = { + > x: int ; + > y: bool option }[@@deriving make]" + $ echo "$test1" > test.ml + $ driver -deriving-keep-w32 both test.ml + type a = { + x: int ; + y: bool option }[@@deriving make] + include struct let make_a ~x ?y () = { x; y } end[@@ocaml.doc "@inline"] + [@@merlin.hide ] + $ echo "$test1" > test.mli + $ driver test.mli + type a = { + x: int ; + y: bool option }[@@deriving make] + include + sig [@@@ocaml.warning "-32"] val make_a : x:int -> ?y:bool -> unit -> a end + [@@ocaml.doc "@inline"][@@merlin.hide ] + + +Test 2: Given a record type b with an option field & a +@main field, make_b accepts the main field as the last +parameter, and does not have a unit in the signature + $ test2=" + > type b = { + > x: int ; + > y: bool [@main] ; + > z : string option}[@@deriving make]" + $ echo "$test2" > test.ml + $ driver -deriving-keep-w32 both test.ml + type b = { + x: int ; + y: bool [@main ]; + z: string option }[@@deriving make] + include struct let make_b ~x ?z y = { x; y; z } end[@@ocaml.doc "@inline"] + [@@merlin.hide ] + $ echo "$test2" > test.mli + $ driver test.mli + type b = { + x: int ; + y: bool [@main ]; + z: string option }[@@deriving make] + include + sig [@@@ocaml.warning "-32"] val make_b : x:int -> ?z:string -> bool -> b + end[@@ocaml.doc "@inline"][@@merlin.hide ] + +Test 3: Given record type c with 2 option fields, one +of which is also annotated with @main, make_c accepts +the main field as the last param, which is of type +`option` but is not optional + $ test3=" + > type c = { + > x: int ; + > y: bool option [@main] ; + > z : string option}[@@deriving make]" + $ echo "$test3" > test.ml + $ driver -deriving-keep-w32 both test.ml + type c = { + x: int ; + y: bool option [@main ]; + z: string option }[@@deriving make] + include struct let make_c ~x ?z y = { x; y; z } end[@@ocaml.doc "@inline"] + [@@merlin.hide ] + $ echo "$test3" > test.mli + $ driver test.mli + type c = { + x: int ; + y: bool option [@main ]; + z: string option }[@@deriving make] + include + sig + [@@@ocaml.warning "-32"] + val make_c : x:int -> ?z:string -> bool option -> c + end[@@ocaml.doc "@inline"][@@merlin.hide ] diff --git a/test/make/optionals.t b/test/make/optionals.t deleted file mode 100644 index 161489a..0000000 --- a/test/make/optionals.t +++ /dev/null @@ -1,164 +0,0 @@ ---------------------------------------------------- -NOTICE: @@ocaml.doc and @@merlin.hide annotations -& `include struct` boilerplate are added by ppxlib. ---------------------------------------------------- - -Test 1: Given a record type a with an `option` field, -make_a will accept an optional param and have a unit -at the end of its signature - $ test1=" - > type a = { - > x: int ; - > y: bool option }[@@deriving make]" - $ echo "$test1" > test.ml - $ driver test.ml - type a = { - x: int ; - y: bool option }[@@deriving make] - include - struct - let _ = fun (_ : a) -> () - let make_a ~x ?y () = { x; y } - let _ = make_a - end[@@ocaml.doc "@inline"][@@merlin.hide ] - $ echo "$test1" > test.mli - $ driver test.mli - type a = { - x: int ; - y: bool option }[@@deriving make] - include - sig [@@@ocaml.warning "-32"] val make_a : x:int -> ?y:bool -> unit -> a end - [@@ocaml.doc "@inline"][@@merlin.hide ] - -Test 2: Given a record type b annotated with `@main` for -one field, make_b will accept the main field as its last -parameter - $ test2=" - > type b = { - > x: int [@main] ; - > y: bool }[@@deriving make]" - $ echo "$test2" > test.ml - $ driver test.ml - type b = { - x: int [@main ]; - y: bool }[@@deriving make] - include - struct - let _ = fun (_ : b) -> () - let make_b ~y x = { x; y } - let _ = make_b - end[@@ocaml.doc "@inline"][@@merlin.hide ] - $ echo "$test2" > test.mli - $ driver test.mli - type b = { - x: int [@main ]; - y: bool }[@@deriving make] - include sig [@@@ocaml.warning "-32"] val make_b : y:bool -> int -> b end - [@@ocaml.doc "@inline"][@@merlin.hide ] - -Test 3: Given a record type c annotated with `@main` for -more than 1 field, throw error - $ test3=" - > type c = { - > x: int ; - > y: bool [@main] ; - > z : string [@main]}[@@deriving make]" - $ echo "$test3" > test.ml - $ driver test.ml - File "test.ml", line 5, characters 2-20: - 5 | z : string [@main]}[@@deriving make] - ^^^^^^^^^^^^^^^^^^ - Error: Duplicate [@deriving.make.main] annotation - [1] - $ echo "$test3" > test.mli - $ driver test.mli - File "test.mli", line 5, characters 2-20: - 5 | z : string [@main]}[@@deriving make] - ^^^^^^^^^^^^^^^^^^ - Error: Duplicate [@deriving.make.main] annotation - [1] - -Test 4: Given a record type d with an option field & a -@main field, make_d accepts the main field as the last -parameter, and does not have a unit in the signature - $ test4=" - > type d = { - > x: int ; - > y: bool [@main] ; - > z : string option}[@@deriving make]" - $ echo "$test4" > test.ml - $ driver test.ml - type d = { - x: int ; - y: bool [@main ]; - z: string option }[@@deriving make] - include - struct - let _ = fun (_ : d) -> () - let make_d ~x ?z y = { x; y; z } - let _ = make_d - end[@@ocaml.doc "@inline"][@@merlin.hide ] - $ echo "$test4" > test.mli - $ driver test.mli - type d = { - x: int ; - y: bool [@main ]; - z: string option }[@@deriving make] - include - sig [@@@ocaml.warning "-32"] val make_d : x:int -> ?z:string -> bool -> d - end[@@ocaml.doc "@inline"][@@merlin.hide ] - -Test 5: Given record type e with 2 option fields, one -of which is also annotated with @main, make_e accepts -the main field as the last param, which is of type -`option` but is not optional - $ test5=" - > type e = { - > x: int ; - > y: bool option [@main] ; - > z : string option}[@@deriving make]" - $ echo "$test5" > test.ml - $ driver -deriving-keep-w32 both test.ml - type e = { - x: int ; - y: bool option [@main ]; - z: string option }[@@deriving make] - include struct let make_e ~x ?z y = { x; y; z } end[@@ocaml.doc "@inline"] - [@@merlin.hide ] - $ echo "$test5" > test.mli - $ driver test.mli - type e = { - x: int ; - y: bool option [@main ]; - z: string option }[@@deriving make] - include - sig - [@@@ocaml.warning "-32"] - val make_e : x:int -> ?z:string -> bool option -> e - end[@@ocaml.doc "@inline"][@@merlin.hide ] - -Test 6: Testing ppxlib: Unexpected attribute payload - $ test6=" - > type l = { - > x: int [@main 5] ; - > y: bool }[@@deriving make]" - $ echo "$test6" > test.mli - $ driver test.mli - File "test.mli", line 3, characters 16-17: - 3 | x: int [@main 5] ; - ^ - Error: [] expected - [1] - -Test 7: Testing ppxlib: Unrecognized annotation - $ test7=" - > type l = { - > x: int [@mein 5] ; - > y: bool }[@@deriving make]" - $ echo "$test7" > test.mli - $ driver -check test.mli - File "test.mli", line 3, characters 11-15: - 3 | x: int [@mein 5] ; - ^^^^ - Error: Attribute `mein' was not used - [1] From 2d6ca9913d885f7e1b2c6ba69ae626955c1a2532 Mon Sep 17 00:00:00 2001 From: aya Date: Tue, 1 Mar 2022 12:34:19 -0500 Subject: [PATCH 38/49] Add list handling, upgrade deriver generator to V2, embed error --- src/make/ppx_make.ml | 86 ++++++++++++++++++++++++++------------------ 1 file changed, 51 insertions(+), 35 deletions(-) diff --git a/src/make/ppx_make.ml b/src/make/ppx_make.ml index fd38a31..8fa7fad 100644 --- a/src/make/ppx_make.ml +++ b/src/make/ppx_make.ml @@ -6,6 +6,8 @@ open Ppxlib open Ast_builder.Default + let extend_error ~loc err_msg = [psig_extension ~loc (Location.error_extensionf ~loc err_msg) []] + module Annotations = struct let default_attr = Attribute.declare @@ -25,10 +27,11 @@ let find_main labels = List.fold_left (fun (main_label, labels) ({ pld_loc; _ } as label) -> - match Attribute.get main_attr label, main_label with - | Some _, Some _ -> Location.raise_errorf ~loc:pld_loc "Duplicate [@deriving.%s.main] annotation" "make" - | Some _, None -> Some label, labels - | None, _ -> main_label, label :: labels) + match Attribute.get main_attr label, main_label with + | Some _, Some _ -> Location.raise_errorf ~loc:pld_loc "Duplicate [@deriving.%s.main] annotation" "make" + | Some _, None -> Some label, labels + | None, _ -> main_label, label :: labels + ) (None, []) labels ;; end @@ -55,10 +58,10 @@ type definition is a record.") ;; - let is_public ~private_ ~loc = + let is_public ~private_ = (match private_ with - | Private -> Location.raise_errorf ~loc "We cannot expose functions that explicitly create private records." - | Public -> () ) + | Private -> false + | Public -> true ) ;; let is_optional labels = List.exists (fun (name, _) -> match name with @@ -75,8 +78,8 @@ ;; let lambda ~loc patterns body = - List.fold_left (fun acc (lab, pat) -> - pexp_fun ~loc lab None pat acc) body patterns + List.fold_left (fun acc (lab, pat, default) -> + pexp_fun ~loc lab default pat acc) body patterns ;; let lambda_sig ~loc arg_tys body_ty = @@ -108,6 +111,8 @@ | Some _, _ -> Optional name.txt, ty (* option type -> Optional *) | _, [%type: [%t? a'] option] -> Optional name.txt, a' + (* list type -> Optional *) + | _, [%type: [%t? _] list] -> Optional name.txt, ty (* regular field -> Labelled *) | _ -> Labelled name.txt, ty ;; @@ -115,8 +120,7 @@ let create_make_sig ~loc ~ty_name ~tps label_decls = let record = Construct.apply_type ~loc ~ty_name ~tps in let main_arg, label_decls = Annotations.find_main label_decls in - let derive_type label_decl = label_arg label_decl in - let types = List.map derive_type label_decls in + let types = List.map label_arg label_decls in let add_unit types = ( Nolabel, Ast_helper.Typ.constr ~loc { txt = Lident "unit"; loc } [] @@ -145,42 +149,53 @@ let tps = List.map (fun (tp, _variance) -> tp) ptype_params in match ptype_kind with | Ptype_record label_decls -> - Check.is_public ~private_ ~loc ; + if Check.is_public ~private_ then let derived_item = create_make_sig ~loc ~ty_name ~tps label_decls in [ derived_item ] + else + extend_error ~loc "We cannot expose functions that explicitly create private records." | _ -> [] ;; - let generate ~loc ~path:_ (rec_flag, tds) = + let generate ~ctxt (rec_flag, tds) = + let loc = Expansion_context.Deriver.derived_item_loc ctxt in Check.is_derivable ~loc rec_flag tds; List.concat_map (derive_per_td) tds ;; end module Gen_struct = struct - let label_arg ~loc label_decl = - let{ pld_name = name; pld_type = ty; _ } = label_decl in - match (Attribute.get Annotations.default_attr label_decl), ty with - | Some _ , _ - | _, [%type: [%t? _] option] -> Optional name.txt, pvar ~loc name.txt - | _ -> Labelled name.txt, pvar ~loc name.txt + let derive_pattern ~loc label_decl = + let { pld_name = name; pld_type = ty; _ } = label_decl in + let default_attr = (Attribute.get Annotations.default_attr label_decl) in + match default_attr, ty with + | Some default_attr, _ -> Optional name.txt, pvar ~loc name.txt, Some default_attr + | _ , [%type: [%t? _] list] -> Optional name.txt, pvar ~loc name.txt, Some (elist ~loc []) + | _, [%type: [%t? _] option] -> Optional name.txt, pvar ~loc name.txt, None + | None, _ -> Labelled name.txt, pvar ~loc name.txt, None + ;; + + let is_optional labels = List.exists (fun (name, _, _) -> match name with + | Optional _ -> true + | _ -> false) labels ;; let create_make_fun ~loc ~record_name label_decls = let field_labels = List.map (fun { pld_name = n; _ } -> n.txt, evar ~loc n.txt) label_decls in - let main_arg, label_decls = Annotations.find_main label_decls in - let derive_pattern label_decl = label_arg ~loc label_decl in - let patterns = List.map derive_pattern label_decls in - let add_unit patterns = (Nolabel, punit ~loc)::patterns in - let patterns = match main_arg with - | Some { pld_name = { txt = name ; _ } ; _ } - -> (Nolabel, pvar ~loc name)::patterns - | None when Check.is_optional patterns -> add_unit patterns - | None -> patterns - in - let create_record = Construct.record ~loc field_labels in - let derive_lambda = Construct.lambda ~loc patterns create_record in - let fun_name = "make_" ^ record_name in + let main_arg, label_decls = Annotations.find_main label_decls in + let patterns = List.map (derive_pattern ~loc) label_decls in + let add_unit patterns = (Nolabel, punit ~loc, None)::patterns in + let patterns = match main_arg with + | Some ({ pld_name = { txt = name ; _ } ; pld_loc; _ } as pld) + -> (match (Attribute.get Annotations.default_attr pld) with + | Some _ -> Location.raise_errorf ~loc:pld_loc "Cannot use both @default and @main" + | None -> (Nolabel, pvar ~loc name, None)::patterns) + | None when is_optional patterns -> add_unit patterns + | None -> patterns + in + let create_record = Construct.record ~loc field_labels in + let derive_lambda = Construct.lambda ~loc patterns create_record in + let fun_name = "make_" ^ record_name in Construct.str_item ~loc fun_name derive_lambda ;; @@ -202,7 +217,8 @@ | _ -> [] ;; - let generate ~loc ~path:_ (rec_flag, tds) = + let generate ~ctxt (rec_flag, tds) = + let loc = Expansion_context.Deriver.derived_item_loc ctxt in Check.is_derivable ~loc rec_flag tds; List.concat_map (derive_per_td) tds ;; @@ -214,11 +230,11 @@ in Deriving.add "make" ~str_type_decl: - (Deriving.Generator.make_noarg + (Deriving.Generator.V2.make_noarg ~attributes Gen_struct.generate) ~sig_type_decl: - (Deriving.Generator.make_noarg + (Deriving.Generator.V2.make_noarg ~attributes Gen_sig.generate) ;; From 9efa6e251bfc0264ca59361e3f2b984ea4e10c1b Mon Sep 17 00:00:00 2001 From: aya Date: Tue, 1 Mar 2022 12:44:41 -0500 Subject: [PATCH 39/49] Add tests for list and default attr --- test/make/annotations.t | 42 +++++++++++++++++++++-------- test/make/{option.t => optionals.t} | 26 ++++++++++++++++++ test/make/signature.t | 14 ++++++---- 3 files changed, 66 insertions(+), 16 deletions(-) rename test/make/{option.t => optionals.t} (77%) diff --git a/test/make/annotations.t b/test/make/annotations.t index e0c1de7..b167a9b 100644 --- a/test/make/annotations.t +++ b/test/make/annotations.t @@ -2,6 +2,12 @@ NOTICE: @@ocaml.doc and @@merlin.hide annotations & `include struct` boilerplate are added by ppxlib. --------------------------------------------------- +The `-deriving-keep-w32 both` flag added after the +driver removes anonymous functions of the type: +- let _ = fun (_ : t) -> () +- let _ = make_t +which are automatically added by ppxlib. +--------------------------------------------------- Test 1: Given a record type a annotated with `@main` for one field, make_a will accept the main field as its last @@ -25,7 +31,7 @@ parameter include sig [@@@ocaml.warning "-32"] val make_a : y:bool -> int -> a end [@@ocaml.doc "@inline"][@@merlin.hide ] -Test 2: Given a record type b annotated with `@main` for +Test 2: Given a record type annotated with `@main` for more than 1 field, throw error $ test2=" > type b = { @@ -66,16 +72,30 @@ Test 3: @default makes the field optional type c = { x: int [@default 5]; y: bool }[@@deriving make] - include struct let make_c ?x ~y () = { x; y } end[@@ocaml.doc "@inline"] - [@@merlin.hide ] + include struct let make_c ?(x= 5) ~y () = { x; y } end[@@ocaml.doc + "@inline"][@@merlin.hide + ] +Test 4: Given a record type with both `@main` and +`@default` for the same field, throw error + $ test4=" + > type d = { + > x: int [@default 5] [@main] ; + > y: bool }[@@deriving make]" + $ echo "$test4" > test.ml + $ driver -deriving-keep-w32 both test.ml + File "test.ml", line 3, characters 2-31: + 3 | x: int [@default 5] [@main] ; + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + Error: Cannot use both @default and @main + [1] -Test 6: Testing ppxlib: Unexpected attribute payload - $ test6=" - > type l = { +Test 5: Testing ppxlib: Unexpected attribute payload + $ test5=" + > type e = { > x: int [@main 5] ; > y: bool }[@@deriving make]" - $ echo "$test6" > test.mli + $ echo "$test5" > test.mli $ driver test.mli File "test.mli", line 3, characters 16-17: 3 | x: int [@main 5] ; @@ -83,12 +103,12 @@ Test 6: Testing ppxlib: Unexpected attribute payload Error: [] expected [1] -Test 7: Testing ppxlib: Unrecognized annotation - $ test7=" - > type l = { +Test 6: Testing ppxlib: Unrecognized annotation + $ test6=" + > type f = { > x: int [@mein 5] ; > y: bool }[@@deriving make]" - $ echo "$test7" > test.mli + $ echo "$test6" > test.mli $ driver -check test.mli File "test.mli", line 3, characters 11-15: 3 | x: int [@mein 5] ; diff --git a/test/make/option.t b/test/make/optionals.t similarity index 77% rename from test/make/option.t rename to test/make/optionals.t index 0229b9c..bddb521 100644 --- a/test/make/option.t +++ b/test/make/optionals.t @@ -87,3 +87,29 @@ the main field as the last param, which is of type [@@@ocaml.warning "-32"] val make_c : x:int -> ?z:string -> bool option -> c end[@@ocaml.doc "@inline"][@@merlin.hide ] + +Test 4: Given a record type `d` with a `list` field, +make_d will accept an optional param with default value +`[]` and will have a unit at the end of its signature + $ test4=" + > type d = { + > x: int list ; + > y: bool }[@@deriving make]" + $ echo "$test4" > test.mli + $ driver test.mli + type d = { + x: int list ; + y: bool }[@@deriving make] + include + sig + [@@@ocaml.warning "-32"] + val make_d : ?x:int list -> y:bool -> unit -> d + end[@@ocaml.doc "@inline"][@@merlin.hide ] + $ echo "$test4" > test.ml + $ driver -deriving-keep-w32 both test.ml + type d = { + x: int list ; + y: bool }[@@deriving make] + include struct let make_d ?(x= []) ~y () = { x; y } end[@@ocaml.doc + "@inline"] + [@@merlin.hide ] diff --git a/test/make/signature.t b/test/make/signature.t index 9070c59..d92b131 100644 --- a/test/make/signature.t +++ b/test/make/signature.t @@ -49,11 +49,15 @@ Test 4: Given a private type, throw error > y: bool }[@@deriving make]" $ echo "$test4" > test.mli $ driver test.mli - File "test.mli", line 2, characters 5-6: - 2 | type d = private { - ^ - Error: We cannot expose functions that explicitly create private records. - [1] + type d = private { + x: int ; + y: bool }[@@deriving make] + include + sig + [@@@ocaml.warning "-32"] + [%%ocaml.error + "We cannot expose functions that explicitly create private records."] + end[@@ocaml.doc "@inline"][@@merlin.hide ] Test 5: Given recursive types which are exclusively record types, expose 1 make function for each record From b44553ee7aadee66ceb32e0eec6531a089fbad18 Mon Sep 17 00:00:00 2001 From: aya Date: Fri, 4 Mar 2022 13:04:51 -0500 Subject: [PATCH 40/49] Change to embed errors --- src/make/ppx_make.ml | 87 ++++++++++++++++++++++------------------- test/make/annotations.t | 47 +++++++++++++--------- test/make/signature.t | 47 ++++++++++++---------- test/make/structure.t | 42 +++++++++++--------- 4 files changed, 126 insertions(+), 97 deletions(-) diff --git a/src/make/ppx_make.ml b/src/make/ppx_make.ml index 8fa7fad..e99e7de 100644 --- a/src/make/ppx_make.ml +++ b/src/make/ppx_make.ml @@ -5,8 +5,6 @@ open Ppxlib open Ast_builder.Default - - let extend_error ~loc err_msg = [psig_extension ~loc (Location.error_extensionf ~loc err_msg) []] module Annotations = struct let default_attr = @@ -26,22 +24,26 @@ ;; let find_main labels = - List.fold_left (fun (main_label, labels) ({ pld_loc; _ } as label) -> - match Attribute.get main_attr label, main_label with - | Some _, Some _ -> Location.raise_errorf ~loc:pld_loc "Duplicate [@deriving.%s.main] annotation" "make" - | Some _, None -> Some label, labels - | None, _ -> main_label, label :: labels - ) - (None, []) labels + let main_labels, labels = List.fold_left (fun (main_labels, labels) label -> + match Attribute.get main_attr label with + | Some _ -> label::main_labels, labels + | None -> main_labels, label :: labels + ) ([], []) labels in + match main_labels with + | [] -> Ok (None, labels) + | [ main_label ] -> Ok (Some main_label, labels) + | main_labels -> Error (List.map(fun ({ pld_loc; _ }) -> + Location.error_extensionf ~loc:pld_loc "Duplicate [@deriving.%s.main] annotation" "make" + ) main_labels ) ;; end module Check = struct let is_derivable ~loc rec_flag tds = - (match rec_flag with + match rec_flag with | Nonrecursive -> - Location.raise_errorf ~loc "nonrec is not compatible with the `make' preprocessor." - | _ -> ()); + Error (Location.error_extensionf ~loc "nonrec is not compatible with the `make' preprocessor.") + | _ -> let is_record td = match td.ptype_kind with | Ptype_record _ -> true @@ -49,19 +51,14 @@ in if not (List.exists is_record tds) then - Location.raise_errorf + Error (Location.error_extensionf ~loc (match tds with | [ _ ] -> "Unsupported use of make (you can only use it on records)." | _ -> "make can only be applied on type definitions in which at least one \ - type definition is a record.") - ;; - - let is_public ~private_ = - (match private_ with - | Private -> false - | Public -> true ) + type definition is a record.")) + else Ok () ;; let is_optional labels = List.exists (fun (name, _) -> match name with @@ -107,19 +104,21 @@ let label_arg label_decl = let { pld_name = name; pld_type = ty; _ } = label_decl in match (Attribute.get Annotations.default_attr label_decl), ty with - (* @default -> Optional *) + (* [@default _ ] -> Optional *) | Some _, _ -> Optional name.txt, ty - (* option type -> Optional *) + (* `option` type -> Optional *) | _, [%type: [%t? a'] option] -> Optional name.txt, a' - (* list type -> Optional *) + (* `list` type -> Optional *) | _, [%type: [%t? _] list] -> Optional name.txt, ty - (* regular field -> Labelled *) + (* Regular field -> Labelled *) | _ -> Labelled name.txt, ty ;; let create_make_sig ~loc ~ty_name ~tps label_decls = let record = Construct.apply_type ~loc ~ty_name ~tps in - let main_arg, label_decls = Annotations.find_main label_decls in + match Annotations.find_main label_decls with + | Error e -> List.map(fun e -> psig_extension ~loc (e) [] ) e + | Ok (main_arg, label_decls) -> let types = List.map label_arg label_decls in let add_unit types = ( Nolabel, @@ -133,7 +132,7 @@ in let t = Construct.lambda_sig ~loc types record in let fun_name = "make_" ^ ty_name in - Construct.sig_item ~loc fun_name t + [Construct.sig_item ~loc fun_name t] ;; let derive_per_td (td : type_declaration) : signature = @@ -149,18 +148,20 @@ let tps = List.map (fun (tp, _variance) -> tp) ptype_params in match ptype_kind with | Ptype_record label_decls -> - if Check.is_public ~private_ then + if private_ = Public then let derived_item = create_make_sig ~loc ~ty_name ~tps label_decls in - [ derived_item ] + derived_item else - extend_error ~loc "We cannot expose functions that explicitly create private records." + [psig_extension ~loc + (Location.error_extensionf ~loc "We cannot expose functions that explicitly create private records.") [] ] | _ -> [] ;; let generate ~ctxt (rec_flag, tds) = let loc = Expansion_context.Deriver.derived_item_loc ctxt in - Check.is_derivable ~loc rec_flag tds; - List.concat_map (derive_per_td) tds + match Check.is_derivable ~loc rec_flag tds with + | Error e -> [psig_extension ~loc (e) [] ] + | Ok () -> List.concat_map (derive_per_td) tds ;; end @@ -182,21 +183,26 @@ let create_make_fun ~loc ~record_name label_decls = let field_labels = List.map (fun { pld_name = n; _ } -> n.txt, evar ~loc n.txt) label_decls in - let main_arg, label_decls = Annotations.find_main label_decls in + match Annotations.find_main label_decls with + | Error e -> List.map(fun e -> pstr_extension ~loc (e) []) e + | Ok (main_arg, label_decls) -> let patterns = List.map (derive_pattern ~loc) label_decls in let add_unit patterns = (Nolabel, punit ~loc, None)::patterns in let patterns = match main_arg with | Some ({ pld_name = { txt = name ; _ } ; pld_loc; _ } as pld) -> (match (Attribute.get Annotations.default_attr pld) with - | Some _ -> Location.raise_errorf ~loc:pld_loc "Cannot use both @default and @main" - | None -> (Nolabel, pvar ~loc name, None)::patterns) - | None when is_optional patterns -> add_unit patterns - | None -> patterns + | Some _ -> Error (Location.error_extensionf ~loc:pld_loc "Cannot use both @default and @main") + | None -> Ok ((Nolabel, pvar ~loc name, None)::patterns)) + | None when is_optional patterns -> Ok (add_unit patterns) + | None -> Ok patterns in + match patterns with + | Error e -> [pstr_extension ~loc (e) []] + | Ok patterns -> let create_record = Construct.record ~loc field_labels in let derive_lambda = Construct.lambda ~loc patterns create_record in let fun_name = "make_" ^ record_name in - Construct.str_item ~loc fun_name derive_lambda + [Construct.str_item ~loc fun_name derive_lambda] ;; let derive_per_td (td : type_declaration) : structure = @@ -213,14 +219,15 @@ (match private_ with | Private -> [] | Public -> let derived_item = create_make_fun ~loc ~record_name label_decls in - [ derived_item ]) + derived_item ) | _ -> [] ;; let generate ~ctxt (rec_flag, tds) = let loc = Expansion_context.Deriver.derived_item_loc ctxt in - Check.is_derivable ~loc rec_flag tds; - List.concat_map (derive_per_td) tds + match Check.is_derivable ~loc rec_flag tds with + | Error e -> [pstr_extension ~loc (e) [] ] + | Ok () -> List.concat_map (derive_per_td) tds ;; end diff --git a/test/make/annotations.t b/test/make/annotations.t index b167a9b..8ec3b4b 100644 --- a/test/make/annotations.t +++ b/test/make/annotations.t @@ -32,26 +32,37 @@ parameter [@@ocaml.doc "@inline"][@@merlin.hide ] Test 2: Given a record type annotated with `@main` for -more than 1 field, throw error +more than 1 field, embed an error for each duplicate $ test2=" > type b = { - > x: int ; + > x: int [@main] ; > y: bool [@main] ; > z : string [@main]}[@@deriving make]" $ echo "$test2" > test.ml $ driver -deriving-keep-w32 both test.ml - File "test.ml", line 5, characters 2-20: - 5 | z : string [@main]}[@@deriving make] - ^^^^^^^^^^^^^^^^^^ - Error: Duplicate [@deriving.make.main] annotation - [1] + type b = { + x: int [@main ]; + y: bool [@main ]; + z: string [@main ]}[@@deriving make] + include + struct + [%%ocaml.error "Duplicate [@deriving.make.main] annotation"] + [%%ocaml.error "Duplicate [@deriving.make.main] annotation"] + [%%ocaml.error "Duplicate [@deriving.make.main] annotation"] + end[@@ocaml.doc "@inline"][@@merlin.hide ] $ echo "$test2" > test.mli $ driver test.mli - File "test.mli", line 5, characters 2-20: - 5 | z : string [@main]}[@@deriving make] - ^^^^^^^^^^^^^^^^^^ - Error: Duplicate [@deriving.make.main] annotation - [1] + type b = { + x: int [@main ]; + y: bool [@main ]; + z: string [@main ]}[@@deriving make] + include + sig + [@@@ocaml.warning "-32"] + [%%ocaml.error "Duplicate [@deriving.make.main] annotation"] + [%%ocaml.error "Duplicate [@deriving.make.main] annotation"] + [%%ocaml.error "Duplicate [@deriving.make.main] annotation"] + end[@@ocaml.doc "@inline"][@@merlin.hide ] Test 3: @default makes the field optional @@ -77,18 +88,18 @@ Test 3: @default makes the field optional ] Test 4: Given a record type with both `@main` and -`@default` for the same field, throw error +`@default` for the same field, embed error $ test4=" > type d = { > x: int [@default 5] [@main] ; > y: bool }[@@deriving make]" $ echo "$test4" > test.ml $ driver -deriving-keep-w32 both test.ml - File "test.ml", line 3, characters 2-31: - 3 | x: int [@default 5] [@main] ; - ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ - Error: Cannot use both @default and @main - [1] + type d = { + x: int [@default 5][@main ]; + y: bool }[@@deriving make] + include struct [%%ocaml.error "Cannot use both @default and @main"] end + [@@ocaml.doc "@inline"][@@merlin.hide ] Test 5: Testing ppxlib: Unexpected attribute payload $ test5=" diff --git a/test/make/signature.t b/test/make/signature.t index d92b131..38c662c 100644 --- a/test/make/signature.t +++ b/test/make/signature.t @@ -16,33 +16,37 @@ Test 1: Given a regular record type a, expose make_a include sig [@@@ocaml.warning "-32"] val make_a : x:int -> y:bool -> a end [@@ocaml.doc "@inline"][@@merlin.hide ] -Test 2: Given a nonrec type, throw error +Test 2: Given a nonrec type, embed error $ test2=" > type nonrec b = { > x: int ; > y: bool }[@@deriving make]" $ echo "$test2" > test.mli $ driver test.mli - File "test.mli", lines 2-4, characters 0-28: - 2 | type nonrec b = { - 3 | x: int ; - 4 | y: bool }[@@deriving make] - Error: nonrec is not compatible with the `make' preprocessor. - [1] + type nonrec b = { + x: int ; + y: bool }[@@deriving make] + include + sig + [@@@ocaml.warning "-32"] + [%%ocaml.error "nonrec is not compatible with the `make' preprocessor."] + end[@@ocaml.doc "@inline"][@@merlin.hide ] -Test 3: Given a non-record type, throw error +Test 3: Given a non-record type, embed error $ test3=" > type c = int * int > [@@deriving make]" $ echo "$test3" > test.mli $ driver test.mli - File "test.mli", lines 2-3, characters 0-17: - 2 | type c = int * int - 3 | [@@deriving make] - Error: Unsupported use of make (you can only use it on records). - [1] + type c = (int * int)[@@deriving make] + include + sig + [@@@ocaml.warning "-32"] + [%%ocaml.error + "Unsupported use of make (you can only use it on records)."] + end[@@ocaml.doc "@inline"][@@merlin.hide ] -Test 4: Given a private type, throw error +Test 4: Given a private type, embed error $ test4=" > type d = private { > x: int ; @@ -102,14 +106,17 @@ record type, expose 1 make function for each type [@@ocaml.doc "@inline"][@@merlin.hide ] Test 7: Given recursive types without any record -types, throw error +types, embed error $ test7=" > type i = int*j > and j = bool*i [@@deriving make]" $ echo "$test7" > test.mli $ driver test.mli - File "test.mli", lines 2-3, characters 0-32: - 2 | type i = int*j - 3 | and j = bool*i [@@deriving make] - Error: make can only be applied on type definitions in which at least one type definition is a record. - [1] + type i = (int * j) + and j = (bool * i)[@@deriving make] + include + sig + [@@@ocaml.warning "-32"] + [%%ocaml.error + "make can only be applied on type definitions in which at least one type definition is a record."] + end[@@ocaml.doc "@inline"][@@merlin.hide ] diff --git a/test/make/structure.t b/test/make/structure.t index a87aae5..ea6c7ee 100644 --- a/test/make/structure.t +++ b/test/make/structure.t @@ -22,31 +22,33 @@ Test 1: Given a regular record type a, derive make_a include struct let make_a ~x ~y = { x; y } end[@@ocaml.doc "@inline"] [@@merlin.hide ] -Test 2: Given a nonrec type, throw error +Test 2: Given a nonrec type, embed error $ test2=" > type nonrec b = { > x: int ; > y: bool }[@@deriving make]" $ echo "$test2" > test.ml $ driver -deriving-keep-w32 both test.ml - File "test.ml", lines 2-4, characters 0-28: - 2 | type nonrec b = { - 3 | x: int ; - 4 | y: bool }[@@deriving make] - Error: nonrec is not compatible with the `make' preprocessor. - [1] + type nonrec b = { + x: int ; + y: bool }[@@deriving make] + include + struct + [%%ocaml.error "nonrec is not compatible with the `make' preprocessor."] + end[@@ocaml.doc "@inline"][@@merlin.hide ] -Test 3: Given a non-record type, throw error +Test 3: Given a non-record type, embed error $ test3=" > type c = int * int > [@@deriving make]" $ echo "$test3" > test.ml $ driver -deriving-keep-w32 both test.ml - File "test.ml", lines 2-3, characters 0-17: - 2 | type c = int * int - 3 | [@@deriving make] - Error: Unsupported use of make (you can only use it on records). - [1] + type c = (int * int)[@@deriving make] + include + struct + [%%ocaml.error + "Unsupported use of make (you can only use it on records)."] + end[@@ocaml.doc "@inline"][@@merlin.hide ] Test 4: Given a private record type d, derive make_d $ test4=" @@ -102,14 +104,16 @@ record type, derive one make function for each type [@@merlin.hide ] Test 7: Given recursive types without any record -types, throw error +types, embed error $ test7=" > type i = int*j > and i = bool*j [@@deriving make]" $ echo "$test7" > test.ml $ driver -deriving-keep-w32 both test.ml - File "test.ml", lines 2-3, characters 0-32: - 2 | type i = int*j - 3 | and i = bool*j [@@deriving make] - Error: make can only be applied on type definitions in which at least one type definition is a record. - [1] + type i = (int * j) + and i = (bool * j)[@@deriving make] + include + struct + [%%ocaml.error + "make can only be applied on type definitions in which at least one type definition is a record."] + end[@@ocaml.doc "@inline"][@@merlin.hide ] From 84b0da3c84687c059f0f886b6882aaed8e0f12f6 Mon Sep 17 00:00:00 2001 From: aya Date: Fri, 4 Mar 2022 15:44:09 -0500 Subject: [PATCH 41/49] Generate opam file --- dune-project | 17 ++++++++++++++++- standard_derivers.opam | 25 +++++++++++++++++++++++++ 2 files changed, 41 insertions(+), 1 deletion(-) create mode 100644 standard_derivers.opam diff --git a/dune-project b/dune-project index ae73029..94619b4 100644 --- a/dune-project +++ b/dune-project @@ -1,2 +1,17 @@ -(lang dune 2.9) +(lang dune 3.0) + (cram enable) + +(generate_opam_files true) + +(name standard_derivers) + +(source + (github ocaml-ppx/standard_derivers)) + +(package + (name standard_derivers) + (synopsis "Standard PPX derivers") + (depends + (ppxlib (>= 0.18.0))) + (allow_empty)) diff --git a/standard_derivers.opam b/standard_derivers.opam new file mode 100644 index 0000000..02233ca --- /dev/null +++ b/standard_derivers.opam @@ -0,0 +1,25 @@ +# This file is generated by dune, edit dune-project instead +opam-version: "2.0" +synopsis: "Standard PPX derivers" +homepage: "https://github.com/ocaml-ppx/standard_derivers" +bug-reports: "https://github.com/ocaml-ppx/standard_derivers/issues" +depends: [ + "dune" {>= "3.0"} + "ppxlib" {>= "0.18.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/ocaml-ppx/standard_derivers.git" From dc12b4a7e98cf77d5b4acfc9316c5c7ec9378e0f Mon Sep 17 00:00:00 2001 From: aya Date: Fri, 4 Mar 2022 15:50:37 -0500 Subject: [PATCH 42/49] Generate opam file --- dune-project | 1 + standard_derivers.opam | 1 + 2 files changed, 2 insertions(+) diff --git a/dune-project b/dune-project index 94619b4..171dc85 100644 --- a/dune-project +++ b/dune-project @@ -13,5 +13,6 @@ (name standard_derivers) (synopsis "Standard PPX derivers") (depends + (ocaml (>= 4.08)) (ppxlib (>= 0.18.0))) (allow_empty)) diff --git a/standard_derivers.opam b/standard_derivers.opam index 02233ca..233972f 100644 --- a/standard_derivers.opam +++ b/standard_derivers.opam @@ -5,6 +5,7 @@ homepage: "https://github.com/ocaml-ppx/standard_derivers" bug-reports: "https://github.com/ocaml-ppx/standard_derivers/issues" depends: [ "dune" {>= "3.0"} + "ocaml" {>= "4.08"} "ppxlib" {>= "0.18.0"} "odoc" {with-doc} ] From 8e8c8b6589f8df70791a48eba55fded7e7b66965 Mon Sep 17 00:00:00 2001 From: aya Date: Thu, 17 Mar 2022 17:16:43 -0400 Subject: [PATCH 43/49] Edit descriptions --- CHANGES.md | 5 ++--- README.md | 21 ++++++++++++++++++++- dune-project | 1 + standard_derivers.opam | 1 + 4 files changed, 24 insertions(+), 4 deletions(-) diff --git a/CHANGES.md b/CHANGES.md index 6f8650c..d715b44 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -1,5 +1,4 @@ -2022-01-XX +Unreleased ----- -- Adding implementation of first standard deriver, (`make`), along with tests and changelog -- Drafting readme to detail documentation for `make` +- Implementation of standard deriver: `make` diff --git a/README.md b/README.md index 83c5fee..e456fa1 100644 --- a/README.md +++ b/README.md @@ -40,4 +40,23 @@ All those points mentioned above might help folks move even more from the sustai @ayc9 is implementing this project as part of an [Outreachy internship](https://www.outreachy.org/) with the OCaml community. The derivers we plan to include are originally written by Jane Street (`ord` and `eq` will come from [`ppx_compare`](https://github.com/janestreet/ppx_compare); the basic structure of `make` will come from [`ppx_fields_conv`](https://github.com/janestreet/ppx_fields_conv)) and by @thierry-martinez (`show` and `pp` will come from [`ppx_show`](https://github.com/thierry-martinez/ppx_show)). - +## `make` + +The `make` deriver generates a constructor function for a given record type `t`. The derived function, `make_t`, accepts labelled arguments for each field in the record. `make_t` is then used to construct records of type `t`. Note that: +- A `[@main]` annotation can be added to specify a field to be the last argument of the constructor function. This main argument will not be labelled. +- A `[@default]` annotation can be added to specify a default value for a given field. Its corresponding argument will be optional. +- Fields of `list` type are automatically set with a default of `[]`. +- If the generated constructor function has optional arguments, it will require the unit `()` as a last argument, except in the case it also has a main argument. + +``` ocaml +type t = { + x : int; + l : int list; + o : int option; + m : int [@main]; + d : int [@default 0] +} [@@deriving make];; + +val make_t : x:int -> ?l:int list -> ?o:int -> ?d:int -> int -> t +let make_t ~x ?(l= []) ?o ?(d= 0) m = { x; l; o; m; d } +``` diff --git a/dune-project b/dune-project index 171dc85..f510af2 100644 --- a/dune-project +++ b/dune-project @@ -12,6 +12,7 @@ (package (name standard_derivers) (synopsis "Standard PPX derivers") + (description "Useful and up-to-date PPX derivers for common tasks.") (depends (ocaml (>= 4.08)) (ppxlib (>= 0.18.0))) diff --git a/standard_derivers.opam b/standard_derivers.opam index 233972f..e243416 100644 --- a/standard_derivers.opam +++ b/standard_derivers.opam @@ -1,6 +1,7 @@ # This file is generated by dune, edit dune-project instead opam-version: "2.0" synopsis: "Standard PPX derivers" +description: "Useful and up-to-date PPX derivers for common tasks." homepage: "https://github.com/ocaml-ppx/standard_derivers" bug-reports: "https://github.com/ocaml-ppx/standard_derivers/issues" depends: [ From bc815253bcf4b8c41552b1cf6cbc53dbf0a79be1 Mon Sep 17 00:00:00 2001 From: aya <48227009+ayc9@users.noreply.github.com> Date: Fri, 8 Apr 2022 10:23:04 -0400 Subject: [PATCH 44/49] Update src/make/ppx_make.ml Co-authored-by: Sonja Heinze --- src/make/ppx_make.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/make/ppx_make.ml b/src/make/ppx_make.ml index e99e7de..25e0d45 100644 --- a/src/make/ppx_make.ml +++ b/src/make/ppx_make.ml @@ -75,8 +75,8 @@ ;; let lambda ~loc patterns body = - List.fold_left (fun acc (lab, pat, default) -> - pexp_fun ~loc lab default pat acc) body patterns + List.fold_left (fun expr (arg_label, default, pat) -> + pexp_fun ~loc arg_label default pat expr) body patterns ;; let lambda_sig ~loc arg_tys body_ty = From 02ad95d05fff45b4b7d0be64b13f73eb08850c91 Mon Sep 17 00:00:00 2001 From: aya <48227009+ayc9@users.noreply.github.com> Date: Fri, 8 Apr 2022 10:23:18 -0400 Subject: [PATCH 45/49] Update src/make/ppx_make.ml Co-authored-by: Sonja Heinze --- src/make/ppx_make.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/make/ppx_make.ml b/src/make/ppx_make.ml index 25e0d45..f16f24e 100644 --- a/src/make/ppx_make.ml +++ b/src/make/ppx_make.ml @@ -80,8 +80,8 @@ ;; let lambda_sig ~loc arg_tys body_ty = - List.fold_left (fun acc (lab, arg_ty) -> - ptyp_arrow ~loc lab arg_ty acc) body_ty arg_tys + List.fold_left (fun return_ty (arg_label, arg_ty) -> + ptyp_arrow ~arg_label lab arg_ty return_ty) body_ty arg_tys ;; let record ~loc pairs = From bd8acd0239a9a6ba83617cc03a274a918c41109a Mon Sep 17 00:00:00 2001 From: aya Date: Fri, 8 Apr 2022 10:25:54 -0400 Subject: [PATCH 46/49] typo --- src/make/ppx_make.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/make/ppx_make.ml b/src/make/ppx_make.ml index f16f24e..d5f4aca 100644 --- a/src/make/ppx_make.ml +++ b/src/make/ppx_make.ml @@ -81,7 +81,7 @@ let lambda_sig ~loc arg_tys body_ty = List.fold_left (fun return_ty (arg_label, arg_ty) -> - ptyp_arrow ~arg_label lab arg_ty return_ty) body_ty arg_tys + ptyp_arrow ~loc arg_label arg_ty return_ty) body_ty arg_tys ;; let record ~loc pairs = From 5aab9358f10076c91767132c150fd086593bd1e2 Mon Sep 17 00:00:00 2001 From: aya Date: Fri, 8 Apr 2022 12:33:31 -0400 Subject: [PATCH 47/49] Updates on PR comments --- README.md | 2 +- src/make/ppx_make.ml | 65 ++++++++++++----------------------------- test/make/annotations.t | 24 ++++++++++----- test/make/signature.t | 11 +++---- test/make/structure.t | 9 +++--- 5 files changed, 47 insertions(+), 64 deletions(-) diff --git a/README.md b/README.md index e456fa1..44bad2f 100644 --- a/README.md +++ b/README.md @@ -22,7 +22,7 @@ Unless there's a good reason not to, we'll stick to the same naming and syntax a #### Hygienic base ecosystem -We'll make sure that the derivers here meet good standards so that people can trust them. That includes good error reporting, using fully qualified names for the derived values, and having a solid set of tests. +We'll make sure that the derivers here meet good standards so that people can trust them. That includes good error reporting, using fully qualified names for the derived values, and having a solid set of tests. We also make sure not to use polymorphic comparisons, because the code generated by a deriver should not depend on the environment in scope. E.g. rather than `foo = []`, we do `match foo with [] ->`, to eliminate the use of `=`, which might be overwritten in the environment. #### Serve as how-to guides diff --git a/src/make/ppx_make.ml b/src/make/ppx_make.ml index d5f4aca..a4ca349 100644 --- a/src/make/ppx_make.ml +++ b/src/make/ppx_make.ml @@ -1,8 +1,3 @@ -(* Generated code should depend on the environment in scope as little as - possible. E.g. rather than [foo = []] do [match foo with [] ->], to - eliminate the use of [=], which might be overwritten in the environment. - It is especially important to not use polymorphic comparisons. *) - open Ppxlib open Ast_builder.Default @@ -13,7 +8,6 @@ Attribute.Context.label_declaration Ast_pattern.(single_expr_payload __) (fun expr -> expr) - ;; let main_attr = Attribute.declare @@ -21,7 +15,6 @@ Attribute.Context.label_declaration Ast_pattern.(pstr nil) () - ;; let find_main labels = let main_labels, labels = List.fold_left (fun (main_labels, labels) label -> @@ -33,16 +26,15 @@ | [] -> Ok (None, labels) | [ main_label ] -> Ok (Some main_label, labels) | main_labels -> Error (List.map(fun ({ pld_loc; _ }) -> - Location.error_extensionf ~loc:pld_loc "Duplicate [@deriving.%s.main] annotation" "make" + Location.error_extensionf ~loc:pld_loc "deriver make: Duplicate [@deriving.make.main] annotation" ) main_labels ) - ;; end module Check = struct let is_derivable ~loc rec_flag tds = match rec_flag with | Nonrecursive -> - Error (Location.error_extensionf ~loc "nonrec is not compatible with the `make' preprocessor.") + Error (Location.error_extensionf ~loc "deriver make: nonrec is not compatible with the `make' preprocessor.") | _ -> let is_record td = match td.ptype_kind with @@ -54,28 +46,21 @@ Error (Location.error_extensionf ~loc (match tds with - | [ _ ] -> "Unsupported use of make (you can only use it on records)." + | [ _ ] -> "deriver make: Unsupported use of make (you can only use it on records)." | _ -> - "make can only be applied on type definitions in which at least one \ + "deriver make: make can only be applied on type definitions in which at least one \ type definition is a record.")) else Ok () - ;; let is_optional labels = List.exists (fun (name, _) -> match name with | Optional _ -> true | _ -> false) labels - ;; end module Construct = struct (* Additional AST construction helpers *) - - let apply_type ~loc ~ty_name ~tps = - ptyp_constr ~loc (Located.lident ~loc ty_name) tps - ;; - let lambda ~loc patterns body = - List.fold_left (fun expr (arg_label, default, pat) -> + List.fold_left (fun expr (arg_label, pat, default) -> pexp_fun ~loc arg_label default pat expr) body patterns ;; @@ -89,15 +74,15 @@ ~loc (List.map (fun (name, exp) -> Located.lident ~loc name, exp) pairs) None - ;; + + let return_type ~loc ~ty_name ~ty_params = + ptyp_constr ~loc (Located.lident ~loc ty_name) ty_params let sig_item ~loc name typ = psig_value ~loc (value_description ~loc ~name:(Located.mk ~loc name) ~type_:typ ~prim:[]) - ;; let str_item ~loc name body = pstr_value ~loc Nonrecursive [ value_binding ~loc ~pat:(pvar ~loc name) ~expr:body ] - ;; end module Gen_sig = struct @@ -112,10 +97,9 @@ | _, [%type: [%t? _] list] -> Optional name.txt, ty (* Regular field -> Labelled *) | _ -> Labelled name.txt, ty - ;; - let create_make_sig ~loc ~ty_name ~tps label_decls = - let record = Construct.apply_type ~loc ~ty_name ~tps in + let create_make_sig ~loc ~ty_name ~ty_params label_decls = + let record = Construct.return_type ~loc ~ty_name ~ty_params in match Annotations.find_main label_decls with | Error e -> List.map(fun e -> psig_extension ~loc (e) [] ) e | Ok (main_arg, label_decls) -> @@ -133,7 +117,6 @@ let t = Construct.lambda_sig ~loc types record in let fun_name = "make_" ^ ty_name in [Construct.sig_item ~loc fun_name t] - ;; let derive_per_td (td : type_declaration) : signature = let { ptype_name = { txt = ty_name; loc } @@ -145,24 +128,21 @@ = td in - let tps = List.map (fun (tp, _variance) -> tp) ptype_params in + let ty_params = List.map (fun (tp, _variance) -> tp) ptype_params in match ptype_kind with | Ptype_record label_decls -> if private_ = Public then - let derived_item = create_make_sig ~loc ~ty_name ~tps label_decls in - derived_item - else + create_make_sig ~loc ~ty_name ~ty_params label_decls + else [psig_extension ~loc - (Location.error_extensionf ~loc "We cannot expose functions that explicitly create private records.") [] ] + (Location.error_extensionf ~loc "deriver make: We cannot expose functions that explicitly create private records.") [] ] | _ -> [] - ;; let generate ~ctxt (rec_flag, tds) = - let loc = Expansion_context.Deriver.derived_item_loc ctxt in - match Check.is_derivable ~loc rec_flag tds with + let loc = Expansion_context.Deriver.derived_item_loc ctxt in + match Check.is_derivable ~loc rec_flag tds with | Error e -> [psig_extension ~loc (e) [] ] | Ok () -> List.concat_map (derive_per_td) tds - ;; end module Gen_struct = struct @@ -174,12 +154,10 @@ | _ , [%type: [%t? _] list] -> Optional name.txt, pvar ~loc name.txt, Some (elist ~loc []) | _, [%type: [%t? _] option] -> Optional name.txt, pvar ~loc name.txt, None | None, _ -> Labelled name.txt, pvar ~loc name.txt, None - ;; let is_optional labels = List.exists (fun (name, _, _) -> match name with | Optional _ -> true | _ -> false) labels - ;; let create_make_fun ~loc ~record_name label_decls = let field_labels = List.map (fun { pld_name = n; _ } -> n.txt, evar ~loc n.txt) label_decls in @@ -191,7 +169,7 @@ let patterns = match main_arg with | Some ({ pld_name = { txt = name ; _ } ; pld_loc; _ } as pld) -> (match (Attribute.get Annotations.default_attr pld) with - | Some _ -> Error (Location.error_extensionf ~loc:pld_loc "Cannot use both @default and @main") + | Some _ -> Error (Location.error_extensionf ~loc:pld_loc "deriver make: Cannot use both @default and @main") | None -> Ok ((Nolabel, pvar ~loc name, None)::patterns)) | None when is_optional patterns -> Ok (add_unit patterns) | None -> Ok patterns @@ -203,7 +181,6 @@ let derive_lambda = Construct.lambda ~loc patterns create_record in let fun_name = "make_" ^ record_name in [Construct.str_item ~loc fun_name derive_lambda] - ;; let derive_per_td (td : type_declaration) : structure = let { ptype_name = { txt = record_name; loc } @@ -218,17 +195,14 @@ | Ptype_record label_decls -> (match private_ with | Private -> [] - | Public -> let derived_item = create_make_fun ~loc ~record_name label_decls in - derived_item ) + | Public -> create_make_fun ~loc ~record_name label_decls ) | _ -> [] - ;; let generate ~ctxt (rec_flag, tds) = let loc = Expansion_context.Deriver.derived_item_loc ctxt in - match Check.is_derivable ~loc rec_flag tds with + match Check.is_derivable ~loc rec_flag tds with | Error e -> [pstr_extension ~loc (e) [] ] | Ok () -> List.concat_map (derive_per_td) tds - ;; end let make = @@ -244,4 +218,3 @@ (Deriving.Generator.V2.make_noarg ~attributes Gen_sig.generate) - ;; diff --git a/test/make/annotations.t b/test/make/annotations.t index 8ec3b4b..a0d9432 100644 --- a/test/make/annotations.t +++ b/test/make/annotations.t @@ -46,9 +46,12 @@ more than 1 field, embed an error for each duplicate z: string [@main ]}[@@deriving make] include struct - [%%ocaml.error "Duplicate [@deriving.make.main] annotation"] - [%%ocaml.error "Duplicate [@deriving.make.main] annotation"] - [%%ocaml.error "Duplicate [@deriving.make.main] annotation"] + [%%ocaml.error + "deriver make: Duplicate [@deriving.make.main] annotation"] + [%%ocaml.error + "deriver make: Duplicate [@deriving.make.main] annotation"] + [%%ocaml.error + "deriver make: Duplicate [@deriving.make.main] annotation"] end[@@ocaml.doc "@inline"][@@merlin.hide ] $ echo "$test2" > test.mli $ driver test.mli @@ -59,9 +62,12 @@ more than 1 field, embed an error for each duplicate include sig [@@@ocaml.warning "-32"] - [%%ocaml.error "Duplicate [@deriving.make.main] annotation"] - [%%ocaml.error "Duplicate [@deriving.make.main] annotation"] - [%%ocaml.error "Duplicate [@deriving.make.main] annotation"] + [%%ocaml.error + "deriver make: Duplicate [@deriving.make.main] annotation"] + [%%ocaml.error + "deriver make: Duplicate [@deriving.make.main] annotation"] + [%%ocaml.error + "deriver make: Duplicate [@deriving.make.main] annotation"] end[@@ocaml.doc "@inline"][@@merlin.hide ] @@ -98,8 +104,10 @@ Test 4: Given a record type with both `@main` and type d = { x: int [@default 5][@main ]; y: bool }[@@deriving make] - include struct [%%ocaml.error "Cannot use both @default and @main"] end - [@@ocaml.doc "@inline"][@@merlin.hide ] + include + struct + [%%ocaml.error "deriver make: Cannot use both @default and @main"] + end[@@ocaml.doc "@inline"][@@merlin.hide ] Test 5: Testing ppxlib: Unexpected attribute payload $ test5=" diff --git a/test/make/signature.t b/test/make/signature.t index 38c662c..19de9ac 100644 --- a/test/make/signature.t +++ b/test/make/signature.t @@ -29,7 +29,8 @@ Test 2: Given a nonrec type, embed error include sig [@@@ocaml.warning "-32"] - [%%ocaml.error "nonrec is not compatible with the `make' preprocessor."] + [%%ocaml.error + "deriver make: nonrec is not compatible with the `make' preprocessor."] end[@@ocaml.doc "@inline"][@@merlin.hide ] Test 3: Given a non-record type, embed error @@ -43,7 +44,7 @@ Test 3: Given a non-record type, embed error sig [@@@ocaml.warning "-32"] [%%ocaml.error - "Unsupported use of make (you can only use it on records)."] + "deriver make: Unsupported use of make (you can only use it on records)."] end[@@ocaml.doc "@inline"][@@merlin.hide ] Test 4: Given a private type, embed error @@ -60,7 +61,7 @@ Test 4: Given a private type, embed error sig [@@@ocaml.warning "-32"] [%%ocaml.error - "We cannot expose functions that explicitly create private records."] + "deriver make: We cannot expose functions that explicitly create private records."] end[@@ocaml.doc "@inline"][@@merlin.hide ] Test 5: Given recursive types which are exclusively @@ -90,7 +91,7 @@ record types, expose 1 make function for each record end[@@ocaml.doc "@inline"][@@merlin.hide ] Test 6: Given recursive types with at least one -record type, expose 1 make function for each type +record type, expose 1 make function for each record $ test6=" > type g = int*h > and h = { @@ -118,5 +119,5 @@ types, embed error sig [@@@ocaml.warning "-32"] [%%ocaml.error - "make can only be applied on type definitions in which at least one type definition is a record."] + "deriver make: make can only be applied on type definitions in which at least one type definition is a record."] end[@@ocaml.doc "@inline"][@@merlin.hide ] diff --git a/test/make/structure.t b/test/make/structure.t index ea6c7ee..9695166 100644 --- a/test/make/structure.t +++ b/test/make/structure.t @@ -34,7 +34,8 @@ Test 2: Given a nonrec type, embed error y: bool }[@@deriving make] include struct - [%%ocaml.error "nonrec is not compatible with the `make' preprocessor."] + [%%ocaml.error + "deriver make: nonrec is not compatible with the `make' preprocessor."] end[@@ocaml.doc "@inline"][@@merlin.hide ] Test 3: Given a non-record type, embed error @@ -47,7 +48,7 @@ Test 3: Given a non-record type, embed error include struct [%%ocaml.error - "Unsupported use of make (you can only use it on records)."] + "deriver make: Unsupported use of make (you can only use it on records)."] end[@@ocaml.doc "@inline"][@@merlin.hide ] Test 4: Given a private record type d, derive make_d @@ -88,7 +89,7 @@ record types, derive 1 make function for each record end[@@ocaml.doc "@inline"][@@merlin.hide ] Test 6: Given recursive types with at least one -record type, derive one make function for each type +record type, derive one make function for each record $ test6=" > type g = int*h > and h = { @@ -115,5 +116,5 @@ types, embed error include struct [%%ocaml.error - "make can only be applied on type definitions in which at least one type definition is a record."] + "deriver make: make can only be applied on type definitions in which at least one type definition is a record."] end[@@ocaml.doc "@inline"][@@merlin.hide ] From bcb7a42b84b752b6332d70ce70744b9801366625 Mon Sep 17 00:00:00 2001 From: aya Date: Mon, 11 Apr 2022 16:41:05 -0400 Subject: [PATCH 48/49] Remove private types check --- src/make/ppx_make.ml | 12 ++---------- test/make/signature.t | 10 +++------- test/make/structure.t | 3 ++- 3 files changed, 7 insertions(+), 18 deletions(-) diff --git a/src/make/ppx_make.ml b/src/make/ppx_make.ml index a4ca349..38fa31f 100644 --- a/src/make/ppx_make.ml +++ b/src/make/ppx_make.ml @@ -120,7 +120,6 @@ let derive_per_td (td : type_declaration) : signature = let { ptype_name = { txt = ty_name; loc } - ; ptype_private = private_ ; ptype_params ; ptype_kind ; _ @@ -131,11 +130,7 @@ let ty_params = List.map (fun (tp, _variance) -> tp) ptype_params in match ptype_kind with | Ptype_record label_decls -> - if private_ = Public then - create_make_sig ~loc ~ty_name ~ty_params label_decls - else - [psig_extension ~loc - (Location.error_extensionf ~loc "deriver make: We cannot expose functions that explicitly create private records.") [] ] + create_make_sig ~loc ~ty_name ~ty_params label_decls | _ -> [] let generate ~ctxt (rec_flag, tds) = @@ -184,7 +179,6 @@ let derive_per_td (td : type_declaration) : structure = let { ptype_name = { txt = record_name; loc } - ; ptype_private = private_ ; ptype_kind ; _ } @@ -193,9 +187,7 @@ in match ptype_kind with | Ptype_record label_decls -> - (match private_ with - | Private -> [] - | Public -> create_make_fun ~loc ~record_name label_decls ) + create_make_fun ~loc ~record_name label_decls | _ -> [] let generate ~ctxt (rec_flag, tds) = diff --git a/test/make/signature.t b/test/make/signature.t index 19de9ac..4c0ef1e 100644 --- a/test/make/signature.t +++ b/test/make/signature.t @@ -47,7 +47,7 @@ Test 3: Given a non-record type, embed error "deriver make: Unsupported use of make (you can only use it on records)."] end[@@ocaml.doc "@inline"][@@merlin.hide ] -Test 4: Given a private type, embed error +Test 4: Given a private type, expose make_d $ test4=" > type d = private { > x: int ; @@ -57,12 +57,8 @@ Test 4: Given a private type, embed error type d = private { x: int ; y: bool }[@@deriving make] - include - sig - [@@@ocaml.warning "-32"] - [%%ocaml.error - "deriver make: We cannot expose functions that explicitly create private records."] - end[@@ocaml.doc "@inline"][@@merlin.hide ] + include sig [@@@ocaml.warning "-32"] val make_d : x:int -> y:bool -> d end + [@@ocaml.doc "@inline"][@@merlin.hide ] Test 5: Given recursive types which are exclusively record types, expose 1 make function for each record diff --git a/test/make/structure.t b/test/make/structure.t index 9695166..25fc595 100644 --- a/test/make/structure.t +++ b/test/make/structure.t @@ -61,7 +61,8 @@ Test 4: Given a private record type d, derive make_d type d = private { x: int ; y: bool }[@@deriving make] - include struct end[@@ocaml.doc "@inline"][@@merlin.hide ] + include struct let make_d ~x ~y = { x; y } end[@@ocaml.doc "@inline"] + [@@merlin.hide ] Test 5: Given recursive types which are exclusively record types, derive 1 make function for each record From a1770f03dae1a7832e8acc77cef3aaaa87785e63 Mon Sep 17 00:00:00 2001 From: aya Date: Wed, 13 Apr 2022 11:59:20 -0400 Subject: [PATCH 49/49] Add comments for non-deriving case --- src/make/ppx_make.ml | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/make/ppx_make.ml b/src/make/ppx_make.ml index 38fa31f..01ab966 100644 --- a/src/make/ppx_make.ml +++ b/src/make/ppx_make.ml @@ -131,6 +131,8 @@ match ptype_kind with | Ptype_record label_decls -> create_make_sig ~loc ~ty_name ~ty_params label_decls + (* Does not derive when matching with the non-record types + of a recursive type definition. See tests for examples. *) | _ -> [] let generate ~ctxt (rec_flag, tds) = @@ -188,6 +190,8 @@ match ptype_kind with | Ptype_record label_decls -> create_make_fun ~loc ~record_name label_decls + (* Does not derive when matching with the non-record types + of a recursive type definition. See tests for examples. *) | _ -> [] let generate ~ctxt (rec_flag, tds) =